----------------------------------------------------------------------------- -- | -- Module : Distribution.Package -- Copyright : LGPL -- -- Maintainer : Isaac Jones -- Stability : alpha -- Portability : GHC -- -- Explanation: This Distribution.Package module provides access to -- information stored in the packages configuration file -- High Level Design: (FIX) module Distribution.Package (PackageConfig(..), PkgIdentifier(..), License(..), Dependency(..), PackageDB, lookupPackage, addPackage, delPackage, allPackages, createPackageDB, withPackageDB, userPkgConfigLocation, systemPkgConfigLocation, -- Less important: basicPackage, cflags, checkLicense, parsePkgRange, parseVersion, exceptionString, filterRange, hunitTests) where -- Local import Distribution.Version hiding (hunitTests) -- base import System.IO (openFile, IOMode(..), hPutStr, hPutStrLn, stdout, stderr) import System.IO.Error (isPermissionError, isAlreadyInUseError, isDoesNotExistError) import System.Directory (doesFileExist, renameFile, removeFile) import Data.Char(toLower, toUpper) import Data.FiniteMap (FiniteMap, emptyFM, addToFM, delFromFM, eltsFM, filterFM, fmToList, listToFM, sizeFM, elemFM, lookupFM) import List (intersperse) import Maybe (catMaybes) import Text.ParserCombinators.Parsec (ParseError, parse, Parser, char) import Time (Month(..)) import Control.Exception as C (try, Exception (..), ioErrors, catch, throwIO) import Control.Monad(when) -- Misc import HUnit hiding (path, State) import Text.XML.HaXml.Types (Element(..), AttValue(..), Attribute, Name) import Text.XML.HaXml.Haskell2Xml (Content(..), Haskell2Xml, HType(..), toHType, fromContents, toContents, hReadXml, hWriteXml, ) data PkgIdentifier = PkgIdentifier {pkgName::String, pkgVersion::Version} deriving (Read, Show, Eq, Ord) {- ^Often need name and version since multiple versions of a single package can exist on a system. -} data PackageConfig = Package { pkgIdent :: PkgIdentifier, license :: License, auto :: Bool, -- provides :: [String], {- A bit pi-in-the-sky; might indicate that this package provides functionality that other packages also provide, such as a compiler or GUI framework, and upon which other packages might depend. -} -- isDefault :: Bool, -- might indicate if this is the default compiler or GUI framework. import_dirs :: [FilePath], source_dirs :: [FilePath], library_dirs :: [FilePath], hs_libraries :: [String], extra_libraries :: [String], include_dirs :: [FilePath], c_includes :: [String], build_deps :: [Dependency], -- build dependencies depends :: [Dependency], -- use dependencies extra_ghc_opts :: [Opt], extra_hugs_opts :: [Opt], extra_nhc_opts :: [Opt], extra_cc_opts :: [Opt], extra_ld_opts :: [Opt], framework_dirs :: [FilePath], extra_frameworks:: [String]} deriving (Read, Show) -- |AllRightsReserved is something without a license. I use -- "AllRightsReserved" instead of "NoLicense" so that people realize -- that when they don't put a licence on something, it becomes very -- restricted. data License = GPL | LGPL | BSD3 | BSD4 | PublicDomain | AllRightsReserved | {- ... | -} OtherLicense FilePath deriving (Read, Show) data Dependency = Dependency String VersionRange deriving (Read, Show) data PackageMap = PackageMap {pkgMap :: FiniteMap PkgIdentifier PackageConfig} data PackageDB = FileDB PackageMap FilePath type Opt = String -- |Hopefully this can be grabbed from a more intelligent Directory -- module. systemPkgConfigLocation :: FilePath systemPkgConfigLocation = "/etc/haskell/packages.conf" userPkgConfigLocation :: String -> FilePath userPkgConfigLocation home = home ++ "/.haskell/packages.conf" -- ------------------------------------------------------------ -- * Read and write system config -- ------------------------------------------------------------ -- better than separate open/commit, because it does -- proper catching of exceptions etc. withPackageDB :: FilePath -> (PackageDB -> IO (PackageDB, a)) -> IO a withPackageDB path f = do C.catch (copyPackageConfig path) (\_ -> return ()) db0 <- try (do h <- openFile path ReadMode s <- hReadXml h return $ FileDB (s::PackageMap) path) case db0 of Right db1 -> (do db2 <- try (f db1) case db2 of Right (db3, retVal) -> do commitPkgDB db3 return retVal Left e -> doEr e) Left e -> doEr e where doEr e' = do -- putStrLn $ "Error: " ++ (exceptionString e') C.catch (restoreOldConfig path) (\_ -> putStrLn "Unable to Restore Configuration.") throwIO e' -- |Errors cought by parent. openPkgDB :: FilePath -> IO PackageDB openPkgDB f = do h <- openFile f ReadMode s <- hReadXml h return $ FileDB (s::PackageMap) f -- |Creates a package database. If it already exists, throw an exception createPackageDB :: FilePath -> (PackageDB -> IO PackageDB) -> IO () createPackageDB path f = (return $ FileDB (PackageMap emptyFM) path) >>= f >>= commitPkgDB -- |Write this package database. commitPkgDB :: PackageDB -> IO () commitPkgDB (FileDB m f) = do h <- openFile (f ++ ".tmp") WriteMode hWriteXml h m renameFile (f ++ ".tmp") f -- |Extract the mapping from package identifiers to packages from the -- database. allPackages :: PackageDB -> [PackageConfig] allPackages (FileDB (PackageMap m) _) = map snd (fmToList m) lookupPackage :: PackageDB -> PkgIdentifier -> Maybe PackageConfig lookupPackage (FileDB (PackageMap m) _) ident = lookupFM m ident -- |Save this package configuration (altered from ghc-pkg) copyPackageConfig :: FilePath -> IO () copyPackageConfig filename = do hPutStr stdout "Saving old package config file... " let oldFile = filename ++ ".old" doesExist <- doesFileExist oldFile `C.catch` (\ _ -> return False) when doesExist (removeFile oldFile `C.catch` (const $ return ())) C.catch (copyFile filename oldFile) (\ err -> do hPutStrLn stderr (unwords [ "Unable to copy " , show filename , " to " , show oldFile ]) throwIO err) hPutStrLn stdout "done." -- |Put the package back in place. restoreOldConfig :: FilePath -> IO () restoreOldConfig filename = do hPutStr stdout "\nWARNING: an error was encountered while the new \n\ \configuration was being written. Attempting to \n\ \restore the old configuration... \n" renameFile (filename ++ ".old") filename hPutStrLn stdout "done." copyFile :: FilePath -> FilePath -> IO () copyFile p1 p2 = readFile p1 >>= writeFile p2 -- ------------------------------------------------------------ -- * add and remove a package -- ------------------------------------------------------------ -- |Add a package to this PackageDB. Still must be "committed" -- ('commitPkgDB') addPackage :: PackageDB -> PackageConfig -> PackageDB addPackage (FileDB (PackageMap inConf) f) conf = FileDB (PackageMap $ addToFM inConf (pkgIdent conf) conf) f -- |Remove a package from this database. Still must be "committed" -- ('commitPkgDB'). The returned Bool is whether or not the package -- was removed. delPackage :: PackageDB -> PkgIdentifier -> (PackageDB, Bool) delPackage (FileDB (PackageMap inConf) f) ident = let removed = elemFM ident inConf in (FileDB (PackageMap $ delFromFM inConf ident) f, removed) -- ------------------------------------------------------------ -- * Misc -- ------------------------------------------------------------ -- |A basic, usable package. basicPackage :: PkgIdentifier -> PackageConfig basicPackage ident = emptyPackage{pkgIdent=ident} -- |provides sensible defaults emptyPackage :: PackageConfig emptyPackage = Package (PkgIdentifier "" NoVersion) AllRightsReserved False [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] -- |Just for fun, check to see if the licences that this package uses -- conflicts with any of the licences of the packages it depends on checkLicense :: PackageConfig -> Bool checkLicense = error "checkLicense is not yet implemented" parseVersion :: String -> Either ParseError Version parseVersion s = parse versionParser "Version" s filterRange :: PackageDB -- ^From this map -> String -- ^Package name -> VersionRange -- ^Ranges to accept -> [PackageConfig] -- ^the elements, having been filtered filterRange (FileDB m _) n1 r = eltsFM $ filterFM (\ (PkgIdentifier n2 v) _ -> n1 == n2 && v `withinRange` r) (pkgMap m) -- |combine fields c_includes, extra_cc_opts cflags :: PackageConfig -> String cflags Package{c_includes=inc, extra_cc_opts=opts} = concat $ intersperse " " ((map ("-I" ++) inc) ++ opts) -- |Convert this list of PackageConfig into a PackageMap packageConfigsToPackageMap :: [PackageConfig] -> PackageMap packageConfigsToPackageMap conf = PackageMap $ foldr (\c m -> addToFM m (pkgIdent c) c) emptyFM conf packageMapToConfigs :: PackageMap -> [PackageConfig] packageMapToConfigs m = map snd (fmToList $ pkgMap m) -- ------------------------------------------------------------ -- * Package Parsing -- ------------------------------------------------------------ showPkgMap :: PackageMap -> String showPkgMap m = show $ fmToList $ pkgMap m -- readsPrecPkgMap :: Int -> String -> [(PackageMap, String)] -- readsPrecPkgMap _ s = [(readPkgMap s, "")] readPkgMap :: String -> PackageMap readPkgMap s = PackageMap $ listToFM $ read s instance Haskell2Xml PackageMap where toHType _ = Prim "packageconf" "packageconf" fromContents ((CElem (Elem "packageconf" _ ps)):[]) = (packageConfigsToPackageMap $ fst $ fromContents ps, []) fromContents _ = error "Internal: unexpected param to fromContents for PackageMap" toContents m = ((CElem (Elem "packageconf" [] (toContents $ packageMapToConfigs m))):[]) instance Haskell2Xml License where toHType _ = Prim "license" "license" fromContents ((CElem (Elem "license" _ [CElem (Elem "otherlicense" _ p)])):[]) = (OtherLicense (fst $ fromContents p), []) fromContents ((CElem (Elem "license" _ [CElem (Elem x _ _)])):[]) = (case map toLower x of "gpl" -> GPL "lgpl" -> LGPL "bsd3" -> BSD3 "bsd4" -> BSD4 "publicdomain" -> PublicDomain "allrightsreserved" -> AllRightsReserved _ -> error "Misparse of license.", []) -- FIX: OtherLicense fromContents _ = error "Misparse of license." --FIX dtd should verify. toContents l = [CElem $ Elem "license" [] (licenseXmlCont l)] where licenseXmlCont (OtherLicense p) = [CElem $ Elem "otherlicense" [] (filePath2Xml p) ] licenseXmlCont l' = [CElem $ Elem (map toLower (show l')) [] [] ] instance Haskell2Xml Dependency where fromContents ((CElem (Elem "dependency" [("name", AttValue [Left d])] vr)):[]) = (Dependency d (fst $ fromContents vr), []) fromContents l@((CElem (Elem a _ _)):_) = error $ "dep error: " ++ (show a) ++ " " ++ (show $ length l) fromContents _ = error "Misparse of dependency." --FIX dtd should verify. toHType _ = Prim "dependency" "dependency" toContents (Dependency d vr) = [CElem $ Elem "dependency" [("name", AttValue [Left d])] (toContents vr)] instance Haskell2Xml VersionRange where fromContents ((CElem (Elem "versionrange" [("type", AttValue [Left (x)])] v)):[]) = (case map toLower x of "any" -> AnyVersion "exactly" -> ExactlyThisVersion (fst $ fromContents v) "orlater" -> OrLaterVersion (fst $ fromContents v) "orearlier" -> OrEarlierVersion (fst $ fromContents v) "strictlylater" -> StrictlyLaterVersion (fst $ fromContents v) "between" -> Between (fst $ fromContents [head v]) (fst $ fromContents (tail v)) "strictlyearlier" -> StrictlyEarlierVersion (fst $ fromContents v) x' -> error $ "Misparse of versionRange: " ++ x', []) -- FIX? fromContents ((CElem (Elem y _ [])):_) = error $ y fromContents _ = error "Misparse of versionRange." --FIX dtd should verify. toHType _ = Prim "versionrange" "versionrange" toContents x = case x of AnyVersion -> vsc "any" [] (ExactlyThisVersion v) -> vsc "exactly" (toContents v) (OrLaterVersion v) -> vsc "orlater" (toContents v) (OrEarlierVersion v) -> vsc "orearlier" (toContents v) (StrictlyLaterVersion v) -> vsc "strictlylater" (toContents v) (StrictlyEarlierVersion v) -> vsc "strictlyearlier" (toContents v) (Between v1 v2) -> vsc "between" (toContents v1 ++ toContents v2) where vsc typeVal conts --versionRangeSmartConstructor = [CElem $ Elem "versionrange" [("type", AttValue [Left (typeVal)])] conts] instance Haskell2Xml Version where fromContents ((CElem (Elem "version" _ [CElem (Elem x _ v)])):[]) = (case map toLower x of "dateversion" -> foldl getDVer (DateVersion 0 January 0) v "numberedversion" -> foldl getNVer (NumberedVersion 0 0 0) v _ -> error "Misparse of package version.", []) --FIX dtd should verify. where getDVer dv@DateVersion{} (CElem (Elem "year" [] [CString False e])) = dv{versionYear=read e} getDVer dv@DateVersion{} (CElem (Elem "month" [] [CString False e])) = dv{versionMonth=read e} getDVer dv@DateVersion{} (CElem (Elem "day" [] [CString False e])) = dv{versionDay=read e} getDVer _ _ = error "Misparse of version." --FIX dtd should verify. getNVer nv@NumberedVersion{} (CElem (Elem "major" [] [CString False e])) = nv{versionMajor=read e} getNVer nv@NumberedVersion{} (CElem (Elem "minor" [] [CString False e])) = nv{versionMinor=read e} getNVer nv@NumberedVersion{} (CElem (Elem "patch" [] [CString False e])) = nv{versionPatchLevel=read e} getNVer _ _ = error "Misparse of package version." --FIX dtd should verify. fromContents _ = error "Misparse of package version." --FIX dtd should verify. toHType _ = Prim "version" "version" toContents x = [CElem $ Elem "version" [] (helper x)] where helper (DateVersion year month day) = [CElem $ Elem "dateversion" [] [basicTag "year" (show year), basicTag "month" (show month), basicTag "day" (show day)]] helper (NumberedVersion major minor patch) = [CElem $ Elem "numberedversion" [] [basicTag "major" (show major), basicTag "minor" (show minor), basicTag "patch" (show patch)]] helper NoVersion = [CElem $ Elem "noversion" [] []] fromContentsMap :: (Haskell2Xml a) => [Content] -> [a] fromContentsMap elems = [fst $ fromContents [x] | x <- elems] contentToFilePaths :: [Content] -> [FilePath] contentToFilePaths ((CElem (Elem "filepath" [] [CString False e])):t) = e:contentToFilePaths t contentToFilePaths ((CElem (Elem x [] y)):_) = error $ "contentToFilePaths: " ++ x ++ " " ++ (show $ length y) contentToFilePaths [] = [] contentToFilePaths _ = error "Internal: bad param to contentToFilePaths." contentToStrList :: String -> [Content] -> [String] contentToStrList s = map contentToStrList' where contentToStrList' :: Content -> Opt contentToStrList' (CElem (Elem s' [] [CString False e'])) | s' == s = e' | otherwise = error "Internal: unexpected param to contentToStrList." contentToStrList' _ = error "Internal: unexpected param to contentToStrList." instance Haskell2Xml PackageConfig where fromContents ((CElem (Elem "package" ats elems)):t) = (foldl getElems (foldl getAts emptyPackage ats) elems, t) where getAts p@Package{pkgIdent=pi'} ("name", AttValue [Left n]) = p{pkgIdent=pi'{pkgName=n}} getAts p ("auto", AttValue [Left b]) = p{auto=(read $ firstUpper b)} getAts _ _ = error "Internal: bad param to getAts" getElems p c@((CElem (Elem "license" _ _))) = p{license=fst (fromContents [c])} getElems p ((CElem (Elem "depends" _ elems'))) = p{depends=fromContentsMap elems' } getElems p ((CElem (Elem "builddepends" _ elems'))) = p{build_deps=fromContentsMap elems' } getElems p@Package{pkgIdent=pi'} c@((CElem (Elem "version" _ _))) = p{pkgIdent=pi'{pkgVersion=fst (fromContents [c])}} getElems p ((CElem (Elem "importdirs" _ elems'))) = p{import_dirs=contentToFilePaths elems'} getElems p ((CElem (Elem "sourcedirs" _ elems'))) = p{source_dirs=contentToFilePaths elems'} getElems p ((CElem (Elem "librarydirs" _ elems'))) = p{library_dirs=contentToFilePaths elems'} getElems p ((CElem (Elem "includedirs" _ elems'))) = p{include_dirs=contentToFilePaths elems'} getElems p ((CElem (Elem "frameworkdirs" _ elems'))) = p{framework_dirs=contentToFilePaths elems'} getElems p ((CElem (Elem "ccopts" _ elems'))) = p{extra_cc_opts=contentToStrList "option" elems'} getElems p ((CElem (Elem "ldopts" _ elems'))) = p{extra_ld_opts=contentToStrList "option" elems'} getElems p ((CElem (Elem "ghcopts" _ elems'))) = p{extra_ghc_opts=contentToStrList "option" elems'} getElems p ((CElem (Elem "hugsopts" _ elems'))) = p{extra_hugs_opts=contentToStrList "option" elems'} getElems p ((CElem (Elem "nhcopts" _ elems'))) = p{extra_nhc_opts=contentToStrList "option" elems'} getElems p ((CElem (Elem "hslibraries" _ elems'))) = p{hs_libraries=contentToStrList "library" elems'} getElems p ((CElem (Elem "extralibraries" _ elems'))) = p{extra_libraries=contentToStrList "library" elems'} getElems p ((CElem (Elem "framework" _ elems'))) = p{extra_frameworks=contentToStrList "extraframeworks" elems'} getElems p ((CElem (Elem "cincludes" _ elems'))) = p{c_includes=contentToStrList "includes" elems'} getElems p _ = p -- FIX: Still needs the other cases. fromContents ((CElem (Elem x _ _)):_) = error $ "Misparse of package config: " ++ x fromContents _ = error "Misparse of package config." --FIX dtd should verify. toHType _ = Prim "package" "package" toContents (Package pIdent pLicense pAuto pImport_dirs pSource_dirs pLibrary_dirs pHs_libraries pExtra_libraries pInclude_dirs pC_includes pBuild_deps pDepends pExtra_ghc_opts pExtra_hugs_opts pExtra_nhc_opts pExtra_cc_opts pExtra_ld_opts pFramework_dirs pExtra_frameworks) = [CElem $ Elem "package" (pkgAttributes pIdent pAuto) (catMaybes $ fileList2Xml "importdirs" pImport_dirs: fileList2Xml "sourcedirs" pSource_dirs: fileList2Xml "librarydirs" pLibrary_dirs: fileList2Xml "includedirs" pInclude_dirs: fileList2Xml "frameworkdirs" pFramework_dirs: basicTagList "option" "ccopts" pExtra_cc_opts: basicTagList "option" "ldopts" pExtra_ld_opts: basicTagList "option" "ghcopts" pExtra_ghc_opts: basicTagList "option" "hugsopts" pExtra_hugs_opts: basicTagList "option" "nhcopts" pExtra_nhc_opts: basicTagList "library" "hslibraries" pHs_libraries: basicTagList "library" "extralibraries" pExtra_libraries: basicTagList "extraframeworks" "framework" pExtra_frameworks: basicTagList "includes" "cincludes" pC_includes: (Just $ CElem $ Elem "depends" [] (concatMap toContents pDepends)): (Just $ CElem $ Elem "builddepends" [] (concatMap toContents pBuild_deps)): (map Just $ toContents pLicense) ++ (map Just $ toContents $ pkgVersion pIdent))] pkgAttributes :: PkgIdentifier -> Bool -> [Attribute] pkgAttributes (PkgIdentifier n _) pAuto = [("name", AttValue [Left n]), ("auto", AttValue [Left $ map toLower $ show pAuto])] fileList2Xml :: Name -> [FilePath] -> Maybe Content fileList2Xml _ [] = Nothing fileList2Xml tag l = Just $ CElem $ Elem tag [] (filePaths2Xml l) -- |Convert a list of filepaths to xml with the "filepath" tag. filePaths2Xml :: [FilePath] -> [Content] filePaths2Xml l = concatMap filePath2Xml l -- |Convert a filepath to xml with the "filepath" tag. filePath2Xml :: FilePath -> [Content] filePath2Xml p = [CElem $ Elem "filepath" [] [CString False p]] -- |Create a basic CString tag w/ the given tag name basicTag :: Name -> String -> Content basicTag t e = CElem $ Elem t [] [CString False e] -- |Create a list of CString items like: -- basicTagList :: Name -> Name -> [String] -> Maybe Content basicTagList _ _ [] = Nothing basicTagList innerTag outerTag l = Just $ CElem $ Elem outerTag [] (map (basicTag innerTag) l) -- ------------------------------------------------------------ -- * Misc. Parsing -- ------------------------------------------------------------ parsePkgIdentifier :: Parser PkgIdentifier parsePkgIdentifier = do pkgName' <- identifier char '-' pkgVersion' <- versionParser return $ PkgIdentifier pkgName' pkgVersion' -- Hugs > Nov-2002 parsePkgRange :: Parser (String, VersionRange) parsePkgRange = do pkgName' <- identifier pkgRange' <- parseVersionRange return (pkgName', pkgRange') -- |Simple ident parser wrapper doPkgRange :: String -> Either String (String, VersionRange) doPkgRange input = case parse parsePkgRange "" input of Left err -> Left (show err) Right y -> Right y -- |Simple ident parser wrapper doIdentParse :: String -> Either String PkgIdentifier doIdentParse input = case parse parsePkgIdentifier "" input of Left err -> Left (show err) Right y -> Right y -- |Make the first char uppercase and the rest lowercase. firstUpper :: String -> String firstUpper [] = [] firstUpper (p:t) = toUpper p:map toLower t -- |Exception String exceptionString :: Exception -> String exceptionString e@(IOException _) = case ioErrors e of Nothing -> "An IO Error Occured" Just er -> if isPermissionError er then "Permission Denied" else if isAlreadyInUseError er then "File Already In Use" else if isDoesNotExistError er then "File Does Not Exist" else "An unknown error occured." exceptionString _ = "An unknown error occured." -- ------------------------------------------------------------ -- * Testing -- ------------------------------------------------------------ hunitTests :: [Test] hunitTests = [ -- package identifiers "my_Package-1.2-3" ~: "failed" ~: (Right $ PkgIdentifier "my_Package" (NumberedVersion 1 2 3)) ~=? doIdentParse "my_Package-1.2-3", -- Basic parsing of package list "empty readShow packageMap" ~: "failed" ~: (sizeFM $ pkgMap $ readPkgMap $ showPkgMap $ PackageMap emptyFM) ~=? 0, "simple readShow packageMap" ~: "failed" ~: (pkgIdent $ snd $ head $ fmToList $ pkgMap $ readPkgMap $ showPkgMap testMap) ~=? testIdent, -- package range "Hugs >= Nov-2002" ~: "failed" ~: (Right ("Hugs", OrLaterVersion tDateVersion2)) ~=? doPkgRange "Hugs >= Nov-2002", "Hugs>Nov-2002" ~: "failed" ~: (Right ("Hugs", StrictlyEarlierVersion tDateVersion2)) ~=? doPkgRange "Hugs