Cabal/src/Distribution/Simple/Program/HcPkg.hs

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