1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE RankNTypes #-} 4{-# LANGUAGE OverloadedStrings #-} 5 6----------------------------------------------------------------------------- 7-- | 8-- Module : Distribution.Simple.Program.HcPkg 9-- Copyright : Duncan Coutts 2009, 2013 10-- 11-- Maintainer : cabal-devel@haskell.org 12-- Portability : portable 13-- 14-- This module provides an library interface to the @hc-pkg@ program. 15-- Currently only GHC and GHCJS have hc-pkg programs. 16 17module Distribution.Simple.Program.HcPkg ( 18 -- * Types 19 HcPkgInfo(..), 20 RegisterOptions(..), 21 defaultRegisterOptions, 22 23 -- * Actions 24 init, 25 invoke, 26 register, 27 unregister, 28 recache, 29 expose, 30 hide, 31 dump, 32 describe, 33 list, 34 35 -- * Program invocations 36 initInvocation, 37 registerInvocation, 38 unregisterInvocation, 39 recacheInvocation, 40 exposeInvocation, 41 hideInvocation, 42 dumpInvocation, 43 describeInvocation, 44 listInvocation, 45 ) where 46 47import Distribution.Compat.Prelude hiding (init) 48import Prelude () 49 50import Distribution.InstalledPackageInfo 51import Distribution.Parsec 52import Distribution.Pretty 53import Distribution.Simple.Compiler 54import Distribution.Simple.Program.Run 55import Distribution.Simple.Program.Types 56import Distribution.Simple.Utils 57import Distribution.Types.ComponentId 58import Distribution.Types.PackageId 59import Distribution.Types.UnitId 60import Distribution.Verbosity 61 62import Data.List (stripPrefix) 63import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), (</>)) 64 65import qualified Data.ByteString as BS 66import qualified Data.ByteString.Lazy as LBS 67import qualified Data.List.NonEmpty as NE 68import qualified System.FilePath.Posix as FilePath.Posix 69 70-- | Information about the features and capabilities of an @hc-pkg@ 71-- program. 72-- 73data HcPkgInfo = HcPkgInfo 74 { hcPkgProgram :: ConfiguredProgram 75 , noPkgDbStack :: Bool -- ^ no package DB stack supported 76 , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags 77 , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db 78 , supportsDirDbs :: Bool -- ^ supports directory style package databases 79 , requiresDirDbs :: Bool -- ^ requires directory style package databases 80 , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag 81 , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache 82 , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent 83 } 84 85 86-- | Call @hc-pkg@ to initialise a package database at the location {path}. 87-- 88-- > hc-pkg init {path} 89-- 90init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () 91init hpi verbosity preferCompat path 92 | not (supportsDirDbs hpi) 93 || (not (requiresDirDbs hpi) && preferCompat) 94 = writeFile path "[]" 95 96 | otherwise 97 = runProgramInvocation verbosity (initInvocation hpi verbosity path) 98 99-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the 100-- provided command-line arguments to it. 101invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () 102invoke hpi verbosity dbStack extraArgs = 103 runProgramInvocation verbosity invocation 104 where 105 args = packageDbStackOpts hpi dbStack ++ extraArgs 106 invocation = programInvocation (hcPkgProgram hpi) args 107 108-- | Additional variations in the behaviour for 'register'. 109data RegisterOptions = RegisterOptions { 110 -- | Allows re-registering \/ overwriting an existing package 111 registerAllowOverwrite :: Bool, 112 113 -- | Insist on the ability to register multiple instances of a 114 -- single version of a single package. This will fail if the @hc-pkg@ 115 -- does not support it, see 'nativeMultiInstance' and 116 -- 'recacheMultiInstance'. 117 registerMultiInstance :: Bool, 118 119 -- | Require that no checks are performed on the existence of package 120 -- files mentioned in the registration info. This must be used if 121 -- registering prior to putting the files in their final place. This will 122 -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. 123 registerSuppressFilesCheck :: Bool 124 } 125 126-- | Defaults are @True@, @False@ and @False@ 127defaultRegisterOptions :: RegisterOptions 128defaultRegisterOptions = RegisterOptions { 129 registerAllowOverwrite = True, 130 registerMultiInstance = False, 131 registerSuppressFilesCheck = False 132 } 133 134-- | Call @hc-pkg@ to register a package. 135-- 136-- > hc-pkg register {filename | -} [--user | --global | --package-db] 137-- 138register :: HcPkgInfo -> Verbosity -> PackageDBStack 139 -> InstalledPackageInfo 140 -> RegisterOptions 141 -> IO () 142register hpi verbosity packagedbs pkgInfo registerOptions 143 | registerMultiInstance registerOptions 144 , not (nativeMultiInstance hpi || recacheMultiInstance hpi) 145 = die' verbosity $ "HcPkg.register: the compiler does not support " 146 ++ "registering multiple instances of packages." 147 148 | registerSuppressFilesCheck registerOptions 149 , not (suppressFilesCheck hpi) 150 = die' verbosity $ "HcPkg.register: the compiler does not support " 151 ++ "suppressing checks on files." 152 153 -- This is a trick. Older versions of GHC do not support the 154 -- --enable-multi-instance flag for ghc-pkg register but it turns out that 155 -- the same ability is available by using ghc-pkg recache. The recache 156 -- command is there to support distro package managers that like to work 157 -- by just installing files and running update commands, rather than 158 -- special add/remove commands. So the way to register by this method is 159 -- to write the package registration file directly into the package db and 160 -- then call hc-pkg recache. 161 -- 162 | registerMultiInstance registerOptions 163 , recacheMultiInstance hpi 164 = do let pkgdb = registrationPackageDB packagedbs 165 writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo 166 recache hpi verbosity pkgdb 167 168 | otherwise 169 = runProgramInvocation verbosity 170 (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) 171 172writeRegistrationFileDirectly :: Verbosity 173 -> HcPkgInfo 174 -> PackageDB 175 -> InstalledPackageInfo 176 -> IO () 177writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo 178 | supportsDirDbs hpi 179 = do let pkgfile = dir </> prettyShow (installedUnitId pkgInfo) <.> "conf" 180 writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) 181 182 | otherwise 183 = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" 184 185writeRegistrationFileDirectly verbosity _ _ _ = 186 -- We don't know here what the dir for the global or user dbs are, 187 -- if that's needed it'll require a bit more plumbing to support. 188 die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" 189 190 191-- | Call @hc-pkg@ to unregister a package 192-- 193-- > hc-pkg unregister [pkgid] [--user | --global | --package-db] 194-- 195unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () 196unregister hpi verbosity packagedb pkgid = 197 runProgramInvocation verbosity 198 (unregisterInvocation hpi verbosity packagedb pkgid) 199 200 201-- | Call @hc-pkg@ to recache the registered packages. 202-- 203-- > hc-pkg recache [--user | --global | --package-db] 204-- 205recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () 206recache hpi verbosity packagedb = 207 runProgramInvocation verbosity 208 (recacheInvocation hpi verbosity packagedb) 209 210 211-- | Call @hc-pkg@ to expose a package. 212-- 213-- > hc-pkg expose [pkgid] [--user | --global | --package-db] 214-- 215expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () 216expose hpi verbosity packagedb pkgid = 217 runProgramInvocation verbosity 218 (exposeInvocation hpi verbosity packagedb pkgid) 219 220-- | Call @hc-pkg@ to retrieve a specific package 221-- 222-- > hc-pkg describe [pkgid] [--user | --global | --package-db] 223-- 224describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] 225describe hpi verbosity packagedb pid = do 226 227 output <- getProgramInvocationLBS verbosity 228 (describeInvocation hpi verbosity packagedb pid) 229 `catchIO` \_ -> return mempty 230 231 case parsePackages output of 232 Left ok -> return ok 233 _ -> die' verbosity $ "failed to parse output of '" 234 ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'" 235 236-- | Call @hc-pkg@ to hide a package. 237-- 238-- > hc-pkg hide [pkgid] [--user | --global | --package-db] 239-- 240hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () 241hide hpi verbosity packagedb pkgid = 242 runProgramInvocation verbosity 243 (hideInvocation hpi verbosity packagedb pkgid) 244 245 246-- | Call @hc-pkg@ to get all the details of all the packages in the given 247-- package database. 248-- 249dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] 250dump hpi verbosity packagedb = do 251 252 output <- getProgramInvocationLBS verbosity 253 (dumpInvocation hpi verbosity packagedb) 254 `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " 255 ++ displayException e 256 257 case parsePackages output of 258 Left ok -> return ok 259 _ -> die' verbosity $ "failed to parse output of '" 260 ++ programId (hcPkgProgram hpi) ++ " dump'" 261 262 263parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] 264parsePackages lbs0 = 265 case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of 266 Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] 267 Left msgs -> Right (NE.toList msgs) 268 where 269 splitPkgs :: LBS.ByteString -> [BS.ByteString] 270 splitPkgs = checkEmpty . doSplit 271 where 272 -- Handle the case of there being no packages at all. 273 checkEmpty [s] | BS.all isSpace8 s = [] 274 checkEmpty ss = ss 275 276 isSpace8 :: Word8 -> Bool 277 isSpace8 9 = True -- '\t' 278 isSpace8 10 = True -- '\n' 279 isSpace8 13 = True -- '\r' 280 isSpace8 32 = True -- ' ' 281 isSpace8 _ = False 282 283 doSplit :: LBS.ByteString -> [BS.ByteString] 284 doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) 285 where 286 go :: [Int64] -> [BS.ByteString] 287 go [] = [ LBS.toStrict lbs ] 288 go (idx:idxs) = 289 let (pfx, sfx) = LBS.splitAt idx lbs 290 in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of 291 Just sfx' -> LBS.toStrict pfx : doSplit sfx' 292 Nothing -> go idxs 293 294 separators :: [LBS.ByteString] 295 separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] 296 297lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString 298#if MIN_VERSION_bytestring(0,10,8) 299lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs 300#else 301lbsStripPrefix pfx lbs 302 | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs) 303 | otherwise = Nothing 304#endif 305 306 307mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo 308-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec 309-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) 310-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. 311-- The "pkgroot" is the directory containing the package database. 312mungePackagePaths pkgroot pkginfo = 313 pkginfo { 314 importDirs = mungePaths (importDirs pkginfo), 315 includeDirs = mungePaths (includeDirs pkginfo), 316 libraryDirs = mungePaths (libraryDirs pkginfo), 317 libraryDynDirs = mungePaths (libraryDynDirs pkginfo), 318 frameworkDirs = mungePaths (frameworkDirs pkginfo), 319 haddockInterfaces = mungePaths (haddockInterfaces pkginfo), 320 haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) 321 } 322 where 323 mungePaths = map mungePath 324 mungeUrls = map mungeUrl 325 326 mungePath p = case stripVarPrefix "${pkgroot}" p of 327 Just p' -> pkgroot </> p' 328 Nothing -> p 329 330 mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of 331 Just p' -> toUrlPath pkgroot p' 332 Nothing -> p 333 334 toUrlPath r p = "file:///" 335 -- URLs always use posix style '/' separators: 336 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) 337 338 stripVarPrefix var p = 339 case splitPath p of 340 (root:path') -> case stripPrefix var root of 341 Just [sep] | isPathSeparator sep -> Just (joinPath path') 342 _ -> Nothing 343 _ -> Nothing 344 345 346-- Older installed package info files did not have the installedUnitId 347-- field, so if it is missing then we fill it as the source package ID. 348-- NB: Internal libraries not supported. 349setUnitId :: InstalledPackageInfo -> InstalledPackageInfo 350setUnitId pkginfo@InstalledPackageInfo { 351 installedUnitId = uid, 352 sourcePackageId = pid 353 } | unUnitId uid == "" 354 = pkginfo { 355 installedUnitId = mkLegacyUnitId pid, 356 installedComponentId_ = mkComponentId (prettyShow pid) 357 } 358setUnitId pkginfo = pkginfo 359 360 361-- | Call @hc-pkg@ to get the source package Id of all the packages in the 362-- given package database. 363-- 364-- This is much less information than with 'dump', but also rather quicker. 365-- Note in particular that it does not include the 'UnitId', just 366-- the source 'PackageId' which is not necessarily unique in any package db. 367-- 368list :: HcPkgInfo -> Verbosity -> PackageDB 369 -> IO [PackageId] 370list hpi verbosity packagedb = do 371 372 output <- getProgramInvocationOutput verbosity 373 (listInvocation hpi verbosity packagedb) 374 `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" 375 376 case parsePackageIds output of 377 Just ok -> return ok 378 _ -> die' verbosity $ "failed to parse output of '" 379 ++ programId (hcPkgProgram hpi) ++ " list'" 380 381 where 382 parsePackageIds = traverse simpleParsec . words 383 384-------------------------- 385-- The program invocations 386-- 387 388initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation 389initInvocation hpi verbosity path = 390 programInvocation (hcPkgProgram hpi) args 391 where 392 args = ["init", path] 393 ++ verbosityOpts hpi verbosity 394 395registerInvocation 396 :: HcPkgInfo -> Verbosity -> PackageDBStack 397 -> InstalledPackageInfo 398 -> RegisterOptions 399 -> ProgramInvocation 400registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = 401 (programInvocation (hcPkgProgram hpi) (args "-")) { 402 progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, 403 progInvokeInputEncoding = IOEncodingUTF8 404 } 405 where 406 cmdname 407 | registerAllowOverwrite registerOptions = "update" 408 | registerMultiInstance registerOptions = "update" 409 | otherwise = "register" 410 411 args file = [cmdname, file] 412 ++ packageDbStackOpts hpi packagedbs 413 ++ [ "--enable-multi-instance" 414 | registerMultiInstance registerOptions ] 415 ++ [ "--force-files" 416 | registerSuppressFilesCheck registerOptions ] 417 ++ verbosityOpts hpi verbosity 418 419unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId 420 -> ProgramInvocation 421unregisterInvocation hpi verbosity packagedb pkgid = 422 programInvocation (hcPkgProgram hpi) $ 423 ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] 424 ++ verbosityOpts hpi verbosity 425 426 427recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB 428 -> ProgramInvocation 429recacheInvocation hpi verbosity packagedb = 430 programInvocation (hcPkgProgram hpi) $ 431 ["recache", packageDbOpts hpi packagedb] 432 ++ verbosityOpts hpi verbosity 433 434 435exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId 436 -> ProgramInvocation 437exposeInvocation hpi verbosity packagedb pkgid = 438 programInvocation (hcPkgProgram hpi) $ 439 ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] 440 ++ verbosityOpts hpi verbosity 441 442describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId 443 -> ProgramInvocation 444describeInvocation hpi verbosity packagedbs pkgid = 445 programInvocation (hcPkgProgram hpi) $ 446 ["describe", prettyShow pkgid] 447 ++ packageDbStackOpts hpi packagedbs 448 ++ verbosityOpts hpi verbosity 449 450hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId 451 -> ProgramInvocation 452hideInvocation hpi verbosity packagedb pkgid = 453 programInvocation (hcPkgProgram hpi) $ 454 ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] 455 ++ verbosityOpts hpi verbosity 456 457 458dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation 459dumpInvocation hpi _verbosity packagedb = 460 (programInvocation (hcPkgProgram hpi) args) { 461 progInvokeOutputEncoding = IOEncodingUTF8 462 } 463 where 464 args = ["dump", packageDbOpts hpi packagedb] 465 ++ verbosityOpts hpi silent 466 -- We use verbosity level 'silent' because it is important that we 467 -- do not contaminate the output with info/debug messages. 468 469listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation 470listInvocation hpi _verbosity packagedb = 471 (programInvocation (hcPkgProgram hpi) args) { 472 progInvokeOutputEncoding = IOEncodingUTF8 473 } 474 where 475 args = ["list", "--simple-output", packageDbOpts hpi packagedb] 476 ++ verbosityOpts hpi silent 477 -- We use verbosity level 'silent' because it is important that we 478 -- do not contaminate the output with info/debug messages. 479 480 481packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] 482packageDbStackOpts hpi dbstack 483 | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] 484 | otherwise = case dbstack of 485 (GlobalPackageDB:UserPackageDB:dbs) -> "--global" 486 : "--user" 487 : map specific dbs 488 (GlobalPackageDB:dbs) -> "--global" 489 : ("--no-user-" ++ packageDbFlag hpi) 490 : map specific dbs 491 _ -> ierror 492 where 493 specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db 494 specific _ = ierror 495 ierror :: a 496 ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) 497 498packageDbFlag :: HcPkgInfo -> String 499packageDbFlag hpi 500 | flagPackageConf hpi 501 = "package-conf" 502 | otherwise 503 = "package-db" 504 505packageDbOpts :: HcPkgInfo -> PackageDB -> String 506packageDbOpts _ GlobalPackageDB = "--global" 507packageDbOpts _ UserPackageDB = "--user" 508packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db 509 510verbosityOpts :: HcPkgInfo -> Verbosity -> [String] 511verbosityOpts hpi v 512 | noVerboseFlag hpi 513 = [] 514 | v >= deafening = ["-v2"] 515 | v == silent = ["-v0"] 516 | otherwise = [] 517