----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC, GHCJS and LHC have hc-pkg programs. module Distribution.Simple.Program.HcPkg ( HcPkgInfo(..), init, invoke, register, reregister, registerMultiInstance, unregister, recache, expose, hide, dump, describe, list, -- * Program invocations initInvocation, registerInvocation, reregisterInvocation, registerMultiInstanceInvocation, unregisterInvocation, recacheInvocation, exposeInvocation, hideInvocation, dumpInvocation, describeInvocation, listInvocation, ) where import Distribution.Package hiding (installedUnitId) import Distribution.InstalledPackageInfo import Distribution.ParseUtils import Distribution.Simple.Compiler import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run import Distribution.Text import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Compat.Exception import Prelude hiding (init) import Data.Char ( isSpace ) import Data.List ( stripPrefix ) import System.FilePath as FilePath ( (), (<.>) , splitPath, splitDirectories, joinPath, isPathSeparator ) import qualified System.FilePath.Posix as FilePath.Posix -- | Information about the features and capabilities of an @hc-pkg@ -- program. -- data HcPkgInfo = HcPkgInfo { hcPkgProgram :: ConfiguredProgram , noPkgDbStack :: Bool -- ^ no package DB stack supported , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db , supportsDirDbs :: Bool -- ^ supports directory style package databases , requiresDirDbs :: Bool -- ^ requires directory style package databases , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache } -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} -- init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () init hpi verbosity preferCompat path | not (supportsDirDbs hpi) || (not (requiresDirDbs hpi) && preferCompat) = writeFile path "[]" | otherwise = runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () invoke hpi verbosity dbStack extraArgs = runProgramInvocation verbosity invocation where args = packageDbStackOpts hpi dbStack ++ extraArgs invocation = programInvocation (hcPkgProgram hpi) args -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] -- register :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () register hpi verbosity packagedb pkgFile = runProgramInvocation verbosity (registerInvocation hpi verbosity packagedb pkgFile) -- | Call @hc-pkg@ to re-register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] -- reregister :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () reregister hpi verbosity packagedb pkgFile = runProgramInvocation verbosity (reregisterInvocation hpi verbosity packagedb pkgFile) registerMultiInstance :: HcPkgInfo -> Verbosity -> PackageDBStack -> InstalledPackageInfo -> IO () registerMultiInstance hpi verbosity packagedbs pkgInfo | nativeMultiInstance hpi = runProgramInvocation verbosity (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo)) -- This is a trick. Older versions of GHC do not support the -- --enable-multi-instance flag for ghc-pkg register but it turns out that -- the same ability is available by using ghc-pkg recache. The recache -- command is there to support distro package managers that like to work -- by just installing files and running update commands, rather than -- special add/remove commands. So the way to register by this method is -- to write the package registration file directly into the package db and -- then call hc-pkg recache. -- | recacheMultiInstance hpi = do let pkgdb = last packagedbs writeRegistrationFileDirectly hpi pkgdb pkgInfo recache hpi verbosity pkgdb | otherwise = die $ "HcPkg.registerMultiInstance: the compiler does not support " ++ "registering multiple instances of packages." writeRegistrationFileDirectly :: HcPkgInfo -> PackageDB -> InstalledPackageInfo -> IO () writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo | supportsDirDbs hpi = do let pkgfile = dir display (installedUnitId pkgInfo) <.> "conf" writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) | otherwise = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" writeRegistrationFileDirectly _ _ _ = -- We don't know here what the dir for the global or user dbs are, -- if that's needed it'll require a bit more plumbing to support. die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] -- unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () unregister hpi verbosity packagedb pkgid = runProgramInvocation verbosity (unregisterInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to recache the registered packages. -- -- > hc-pkg recache [--user | --global | --package-db] -- recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () recache hpi verbosity packagedb = runProgramInvocation verbosity (recacheInvocation hpi verbosity packagedb) -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] -- expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () expose hpi verbosity packagedb pkgid = runProgramInvocation verbosity (exposeInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to retrieve a specific package -- -- > hc-pkg describe [pkgid] [--user | --global | --package-db] -- describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] describe hpi verbosity packagedb pid = do output <- getProgramInvocationOutput verbosity (describeInvocation hpi verbosity packagedb pid) `catchIO` \_ -> return "" case parsePackages output of Left ok -> return ok _ -> die $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'" -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] -- hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () hide hpi verbosity packagedb pkgid = runProgramInvocation verbosity (hideInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. -- dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] dump hpi verbosity packagedb = do output <- getProgramInvocationOutput verbosity (dumpInvocation hpi verbosity packagedb) `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed" case parsePackages output of Left ok -> return ok _ -> die $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " dump'" parsePackages :: String -> Either [InstalledPackageInfo] [PError] parsePackages str = let parsed = map parseInstalledPackageInfo' (splitPkgs str) in case [ msg | ParseFailed msg <- parsed ] of [] -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | ParseOk _ pkg <- parsed ] msgs -> Right msgs where parseInstalledPackageInfo' = parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo --TODO: this could be a lot faster. We're doing normaliseLineEndings twice -- and converting back and forth with lines/unlines. splitPkgs :: String -> [String] splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines where -- Handle the case of there being no packages at all. checkEmpty [s] | all isSpace s = [] checkEmpty ss = ss splitWith :: (a -> Bool) -> [a] -> [[a]] splitWith p xs = ys : case zs of [] -> [] _:ws -> splitWith p ws where (ys,zs) = break p xs mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. mungePackagePaths pkgroot pkginfo = pkginfo { importDirs = mungePaths (importDirs pkginfo), includeDirs = mungePaths (includeDirs pkginfo), libraryDirs = mungePaths (libraryDirs pkginfo), frameworkDirs = mungePaths (frameworkDirs pkginfo), haddockInterfaces = mungePaths (haddockInterfaces pkginfo), haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) } where mungePaths = map mungePath mungeUrls = map mungeUrl mungePath p = case stripVarPrefix "${pkgroot}" p of Just p' -> pkgroot p' Nothing -> p mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of Just p' -> toUrlPath pkgroot p' Nothing -> p toUrlPath r p = "file:///" -- URLs always use posix style '/' separators: ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) stripVarPrefix var p = case splitPath p of (root:path') -> case stripPrefix var root of Just [sep] | isPathSeparator sep -> Just (joinPath path') _ -> Nothing _ -> Nothing -- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo setUnitId pkginfo@InstalledPackageInfo { installedUnitId = SimpleUnitId (ComponentId ""), sourcePackageId = pkgid } = pkginfo { installedUnitId = mkLegacyUnitId pkgid } setUnitId pkginfo = pkginfo -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker. -- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db. -- list :: HcPkgInfo -> Verbosity -> PackageDB -> IO [PackageId] list hpi verbosity packagedb = do output <- getProgramInvocationOutput verbosity (listInvocation hpi verbosity packagedb) `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" case parsePackageIds output of Just ok -> return ok _ -> die $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " list'" where parsePackageIds = sequence . map simpleParse . words -------------------------- -- The program invocations -- initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation initInvocation hpi verbosity path = programInvocation (hcPkgProgram hpi) args where args = ["init", path] ++ verbosityOpts hpi verbosity registerInvocation, reregisterInvocation, registerMultiInstanceInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation registerInvocation = registerInvocation' "register" False reregisterInvocation = registerInvocation' "update" False registerMultiInstanceInvocation = registerInvocation' "update" True registerInvocation' :: String -> Bool -> HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation registerInvocation' cmdname multiInstance hpi verbosity packagedbs pkgFileOrInfo = case pkgFileOrInfo of Left pkgFile -> programInvocation (hcPkgProgram hpi) (args pkgFile) Right pkgInfo -> (programInvocation (hcPkgProgram hpi) (args "-")) { progInvokeInput = Just (showInstalledPackageInfo pkgInfo), progInvokeInputEncoding = IOEncodingUTF8 } where args file = [cmdname, file] ++ (if noPkgDbStack hpi then [packageDbOpts hpi (last packagedbs)] else packageDbStackOpts hpi packagedbs) ++ [ "--enable-multi-instance" | multiInstance ] ++ verbosityOpts hpi verbosity unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation unregisterInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ ["unregister", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation recacheInvocation hpi verbosity packagedb = programInvocation (hcPkgProgram hpi) $ ["recache", packageDbOpts hpi packagedb] ++ verbosityOpts hpi verbosity exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation exposeInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ ["expose", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> ProgramInvocation describeInvocation hpi verbosity packagedbs pkgid = programInvocation (hcPkgProgram hpi) $ ["describe", display pkgid] ++ (if noPkgDbStack hpi then [packageDbOpts hpi (last packagedbs)] else packageDbStackOpts hpi packagedbs) ++ verbosityOpts hpi verbosity hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation hideInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ ["hide", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation dumpInvocation hpi _verbosity packagedb = (programInvocation (hcPkgProgram hpi) args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = ["dump", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent -- We use verbosity level 'silent' because it is important that we -- do not contaminate the output with info/debug messages. listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation listInvocation hpi _verbosity packagedb = (programInvocation (hcPkgProgram hpi) args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = ["list", "--simple-output", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent -- We use verbosity level 'silent' because it is important that we -- do not contaminate the output with info/debug messages. packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] packageDbStackOpts hpi dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> "--global" : "--user" : map specific dbs (GlobalPackageDB:dbs) -> "--global" : ("--no-user-" ++ packageDbFlag hpi) : map specific dbs _ -> ierror where specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db specific _ = ierror ierror :: a ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi | flagPackageConf hpi = "package-conf" | otherwise = "package-db" packageDbOpts :: HcPkgInfo -> PackageDB -> String packageDbOpts _ GlobalPackageDB = "--global" packageDbOpts _ UserPackageDB = "--user" packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db verbosityOpts :: HcPkgInfo -> Verbosity -> [String] verbosityOpts hpi v | noVerboseFlag hpi = [] | v >= deafening = ["-v2"] | v == silent = ["-v0"] | otherwise = []