cabal-install/src/Distribution/Client/Get.hs

   1 -----------------------------------------------------------------------------
   2
   3 -----------------------------------------------------------------------------
   4
   5 -- |
   6 -- Module      :  Distribution.Client.Get
   7 -- Copyright   :  (c) Andrea Vezzosi 2008
   8 --                    Duncan Coutts 2011
   9 --                    John Millikin 2012
  10 -- License     :  BSD-like
  11 --
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Stability   :  provisional
  14 -- Portability :  portable
  15 --
  16 -- The 'cabal get' command.
  17 module Distribution.Client.Get
  18   ( get
  19
  20     -- * Cloning 'SourceRepo's
  21
  22     -- | Mainly exported for testing purposes
  23   , clonePackagesFromSourceRepo
  24   , ClonePackageException (..)
  25   ) where
  26
  27 import Distribution.Client.Compat.Prelude hiding (get)
  28 import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..), srpToProxy)
  29 import Distribution.Compat.Directory
  30   ( listDirectory
  31   )
  32 import Distribution.Package
  33   ( PackageId
  34   , packageId
  35   , packageName
  36   )
  37 import qualified Distribution.PackageDescription as PD
  38 import Distribution.Simple.Program
  39   ( programName
  40   )
  41 import Distribution.Simple.Setup
  42   ( Flag (..)
  43   , flagToMaybe
  44   , fromFlag
  45   , fromFlagOrDefault
  46   )
  47 import Distribution.Simple.Utils
  48   ( dieWithException
  49   , info
  50   , notice
  51   , warn
  52   , writeFileAtomic
  53   )
  54 import Distribution.Types.SourceRepo (RepoKind (..))
  55 import Prelude ()
  56
  57 import Distribution.Client.Dependency
  58 import Distribution.Client.FetchUtils
  59 import Distribution.Client.IndexUtils
  60   ( ActiveRepos
  61   , TotalIndexState
  62   , getSourcePackagesAtIndexState
  63   )
  64 import Distribution.Client.Setup
  65   ( GetFlags (..)
  66   , GlobalFlags (..)
  67   , RepoContext (..)
  68   )
  69 import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
  70 import Distribution.Client.Targets
  71 import Distribution.Client.Types
  72 import Distribution.Client.VCS
  73 import Distribution.PackageDescription.PrettyPrint
  74   ( writeGenericPackageDescription
  75   )
  76 import Distribution.Solver.Types.SourcePackage
  77
  78 import Control.Monad (mapM_)
  79 import qualified Data.Map as Map
  80 import Distribution.Client.Errors
  81 import Distribution.Utils.NubList
  82   ( fromNubList
  83   )
  84 import System.Directory
  85   ( createDirectoryIfMissing
  86   , doesDirectoryExist
  87   , doesFileExist
  88   )
  89 import System.FilePath
  90   ( addTrailingPathSeparator
  91   , (<.>)
  92   , (</>)
  93   )
  94
  95 -- | Entry point for the 'cabal get' command.
  96 get
  97   :: Verbosity
  98   -> RepoContext
  99   -> GlobalFlags
 100   -> GetFlags
 101   -> [UserTarget]
 102   -> IO ()
 103 get verbosity _ _ _ [] =
 104   notice verbosity "No packages requested. Nothing to do."
 105 get verbosity repoCtxt globalFlags getFlags userTargets = do
 106   let useSourceRepo = case getSourceRepository getFlags of
 107         NoFlag -> False
 108         _ -> True
 109
 110   unless useSourceRepo $
 111     traverse_ (checkTarget verbosity) userTargets
 112
 113   let idxState :: Maybe TotalIndexState
 114       idxState = flagToMaybe $ getIndexState getFlags
 115
 116       activeRepos :: Maybe ActiveRepos
 117       activeRepos = flagToMaybe $ getActiveRepos getFlags
 118
 119   (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
 120
 121   pkgSpecifiers <-
 122     resolveUserTargets
 123       verbosity
 124       repoCtxt
 125       (packageIndex sourcePkgDb)
 126       userTargets
 127
 128   pkgs <-
 129     either (dieWithException verbosity . PkgSpecifierException . map show) return $
 130       resolveWithoutDependencies
 131         (resolverParams sourcePkgDb pkgSpecifiers)
 132
 133   unless (null prefix) $
 134     createDirectoryIfMissing True prefix
 135
 136   if onlyPkgDescr
 137     then do
 138       when useSourceRepo $
 139         warn verbosity $
 140           "Ignoring --source-repository for --only-package-description"
 141
 142       mapM_ (unpackOnlyPkgDescr verbosity prefix) pkgs
 143     else
 144       if useSourceRepo
 145         then clone pkgs
 146         else unpack pkgs
 147   where
 148     resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
 149     resolverParams sourcePkgDb pkgSpecifiers =
 150       -- TODO: add command-line constraint and preference args for unpack
 151       standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
 152
 153     onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags)
 154
 155     prefix :: String
 156     prefix = fromFlagOrDefault "" (getDestDir getFlags)
 157
 158     clone :: [UnresolvedSourcePackage] -> IO ()
 159     clone =
 160       clonePackagesFromSourceRepo verbosity prefix kind (fromNubList $ globalProgPathExtra globalFlags)
 161         . map (\pkg -> (packageId pkg, packageSourceRepos pkg))
 162       where
 163         kind :: Maybe RepoKind
 164         kind = fromFlag . getSourceRepository $ getFlags
 165         packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]
 166         packageSourceRepos =
 167           PD.sourceRepos
 168             . PD.packageDescription
 169             . srcpkgDescription
 170
 171     unpack :: [UnresolvedSourcePackage] -> IO ()
 172     unpack pkgs = do
 173       for_ pkgs $ \pkg -> do
 174         location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg)
 175         let pkgid = packageId pkg
 176             descOverride
 177               | usePristine = Nothing
 178               | otherwise = srcpkgDescrOverride pkg
 179         case location of
 180           LocalTarballPackage tarballPath ->
 181             unpackPackage verbosity prefix pkgid descOverride tarballPath
 182           RemoteTarballPackage _tarballURL tarballPath ->
 183             unpackPackage verbosity prefix pkgid descOverride tarballPath
 184           RepoTarballPackage _repo _pkgid tarballPath ->
 185             unpackPackage verbosity prefix pkgid descOverride tarballPath
 186           RemoteSourceRepoPackage _repo _ ->
 187             dieWithException verbosity UnpackGet
 188           LocalUnpackedPackage _ ->
 189             error "Distribution.Client.Get.unpack: the impossible happened."
 190       where
 191         usePristine :: Bool
 192         usePristine = fromFlagOrDefault False (getPristine getFlags)
 193
 194 checkTarget :: Verbosity -> UserTarget -> IO ()
 195 checkTarget verbosity target = case target of
 196   UserTargetLocalDir dir -> dieWithException verbosity $ NotTarballDir dir
 197   UserTargetLocalCabalFile file -> dieWithException verbosity $ NotTarballDir file
 198   _ -> return ()
 199
 200 {-where
 201     notTarball t =
 202       "The 'get' command is for tarball packages. "
 203         ++ "The target '"
 204         ++ t
 205         ++ "' is not a tarball."
 206 -}
 207 -- ------------------------------------------------------------
 208
 209 -- * Unpacking the source tarball
 210
 211 -- ------------------------------------------------------------
 212
 213 unpackPackage
 214   :: Verbosity
 215   -> FilePath
 216   -> PackageId
 217   -> PackageDescriptionOverride
 218   -> FilePath
 219   -> IO ()
 220 unpackPackage verbosity prefix pkgid descOverride pkgPath = do
 221   let pkgdirname = prettyShow pkgid
 222       pkgdir = prefix </> pkgdirname
 223       pkgdir' = addTrailingPathSeparator pkgdir
 224       emptyDirectory directory = null <$> listDirectory directory
 225   existsDir <- doesDirectoryExist pkgdir
 226   when existsDir $ do
 227     isEmpty <- emptyDirectory pkgdir
 228     unless isEmpty $
 229       dieWithException verbosity $
 230         DirectoryAlreadyExists pkgdir'
 231   existsFile <- doesFileExist pkgdir
 232   when existsFile $
 233     dieWithException verbosity $
 234       FileExists pkgdir
 235   notice verbosity $ "Unpacking to " ++ pkgdir'
 236   Tar.extractTarGzFile prefix pkgdirname pkgPath
 237
 238   case descOverride of
 239     Nothing -> return ()
 240     Just pkgtxt -> do
 241       let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"
 242       info verbosity $
 243         "Updating "
 244           ++ descFilePath
 245           ++ " with the latest revision from the index."
 246       writeFileAtomic descFilePath pkgtxt
 247
 248 -- | Write a @pkgId.cabal@ file with the package description to the destination
 249 -- directory, unless one already exists.
 250 unpackOnlyPkgDescr :: Verbosity -> FilePath -> UnresolvedSourcePackage -> IO ()
 251 unpackOnlyPkgDescr verbosity dstDir pkg = do
 252   let pkgFile = dstDir </> prettyShow (packageId pkg) <.> "cabal"
 253   existsFile <- doesFileExist pkgFile
 254   when existsFile $
 255     dieWithException verbosity $
 256       FileAlreadyExists pkgFile
 257   existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile)
 258   when existsDir $
 259     dieWithException verbosity $
 260       DirectoryExists pkgFile
 261   notice verbosity $ "Writing package description to " ++ pkgFile
 262   case srcpkgDescrOverride pkg of
 263     Just pkgTxt -> writeFileAtomic pkgFile pkgTxt
 264     Nothing ->
 265       writeGenericPackageDescription pkgFile (srcpkgDescription pkg)
 266
 267 -- ------------------------------------------------------------
 268
 269 -- * Cloning packages from their declared source repositories
 270
 271 -- ------------------------------------------------------------
 272
 273 data ClonePackageException
 274   = ClonePackageNoSourceRepos PackageId
 275   | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
 276   | ClonePackageNoRepoType PackageId PD.SourceRepo
 277   | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
 278   | ClonePackageNoRepoLocation PackageId PD.SourceRepo
 279   | ClonePackageDestinationExists PackageId FilePath Bool
 280   | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode
 281   deriving (Show, Eq)
 282
 283 instance Exception ClonePackageException where
 284   displayException (ClonePackageNoSourceRepos pkgid) =
 285     "Cannot fetch a source repository for package "
 286       ++ prettyShow pkgid
 287       ++ ". The package does not specify any source repositories."
 288   displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =
 289     "Cannot fetch a source repository for package "
 290       ++ prettyShow pkgid
 291       ++ ". The package does not specify a source repository of the requested "
 292       ++ "kind"
 293       ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind
 294   displayException (ClonePackageNoRepoType pkgid _repo) =
 295     "Cannot fetch the source repository for package "
 296       ++ prettyShow pkgid
 297       ++ ". The package's description specifies a source repository but does "
 298       ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
 299   displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =
 300     "Cannot fetch the source repository for package "
 301       ++ prettyShow pkgid
 302       ++ ". The repository type '"
 303       ++ prettyShow repoType
 304       ++ "' is not yet supported."
 305   displayException (ClonePackageNoRepoLocation pkgid _repo) =
 306     "Cannot fetch the source repository for package "
 307       ++ prettyShow pkgid
 308       ++ ". The package's description specifies a source repository but does "
 309       ++ "not specify the repository 'location' field (i.e. the URL)."
 310   displayException (ClonePackageDestinationExists pkgid dest isdir) =
 311     "Not fetching the source repository for package "
 312       ++ prettyShow pkgid
 313       ++ ". "
 314       ++ if isdir
 315         then "The destination directory " ++ dest ++ " already exists."
 316         else "A file " ++ dest ++ " is in the way."
 317   displayException
 318     ( ClonePackageFailedWithExitCode
 319         pkgid
 320         repo
 321         vcsprogname
 322         exitcode
 323       ) =
 324       "Failed to fetch the source repository for package "
 325         ++ prettyShow pkgid
 326         ++ ", repository location "
 327         ++ srpLocation repo
 328         ++ " ("
 329         ++ vcsprogname
 330         ++ " failed with "
 331         ++ show exitcode
 332         ++ ")."
 333
 334 -- | Given a bunch of package ids and their corresponding available
 335 -- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into
 336 -- new subdirs of the given directory.
 337 clonePackagesFromSourceRepo
 338   :: Verbosity
 339   -> FilePath
 340   -- ^ destination dir prefix
 341   -> Maybe RepoKind
 342   -- ^ preferred 'RepoKind'
 343   -> [FilePath]
 344   -- ^ Extra prog paths
 345   -> [(PackageId, [PD.SourceRepo])]
 346   -- ^ the packages and their
 347   -- available 'SourceRepo's
 348   -> IO ()
 349 clonePackagesFromSourceRepo
 350   verbosity
 351   destDirPrefix
 352   preferredRepoKind
 353   progPaths
 354   pkgrepos = do
 355     -- Do a bunch of checks and collect the required info
 356     pkgrepos' <- traverse preCloneChecks pkgrepos
 357
 358     -- Configure the VCS drivers for all the repository types we may need
 359     vcss <-
 360       configureVCSs verbosity progPaths $
 361         Map.fromList
 362           [ (vcsRepoType vcs, vcs)
 363           | (_, _, vcs, _) <- pkgrepos'
 364           ]
 365
 366     -- Now execute all the required commands for each repo
 367     sequence_
 368       [ cloneSourceRepo verbosity vcs' repo destDir
 369         `catch` \exitcode ->
 370           throwIO
 371             ( ClonePackageFailedWithExitCode
 372                 pkgid
 373                 (srpToProxy repo)
 374                 (programName (vcsProgram vcs))
 375                 exitcode
 376             )
 377       | (pkgid, repo, vcs, destDir) <- pkgrepos'
 378       , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss
 379       ]
 380     where
 381       preCloneChecks
 382         :: (PackageId, [PD.SourceRepo])
 383         -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
 384       preCloneChecks (pkgid, repos) = do
 385         repo <- case selectPackageSourceRepo preferredRepoKind repos of
 386           Just repo -> return repo
 387           Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)
 388           Nothing ->
 389             throwIO
 390               ( ClonePackageNoSourceReposOfKind
 391                   pkgid
 392                   preferredRepoKind
 393               )
 394
 395         (repo', vcs) <- case validatePDSourceRepo repo of
 396           Right (repo', _, _, vcs) -> return (repo', vcs)
 397           Left SourceRepoRepoTypeUnspecified ->
 398             throwIO (ClonePackageNoRepoType pkgid repo)
 399           Left (SourceRepoRepoTypeUnsupported repo' repoType) ->
 400             throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)
 401           Left SourceRepoLocationUnspecified ->
 402             throwIO (ClonePackageNoRepoLocation pkgid repo)
 403
 404         let destDir :: FilePath
 405             destDir = destDirPrefix </> prettyShow (packageName pkgid)
 406         destDirExists <- doesDirectoryExist destDir
 407         destFileExists <- doesFileExist destDir
 408         when (destDirExists || destFileExists) $
 409           throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
 410
 411         return (pkgid, repo', vcs, destDir)
 412
 413 -------------------------------------------------------------------------------
 414 -- Selecting
 415 -------------------------------------------------------------------------------
 416
 417 -- | Pick the 'SourceRepo' to use to get the package sources from.
 418 --
 419 -- Note that this does /not/ depend on what 'VCS' drivers we are able to
 420 -- successfully configure. It is based only on the 'SourceRepo's declared
 421 -- in the package, and optionally on a preferred 'RepoKind'.
 422 selectPackageSourceRepo
 423   :: Maybe RepoKind
 424   -> [PD.SourceRepo]
 425   -> Maybe PD.SourceRepo
 426 selectPackageSourceRepo preferredRepoKind =
 427   listToMaybe
 428     -- Sort repositories by kind, from This to Head to Unknown. Repositories
 429     -- with equivalent kinds are selected based on the order they appear in
 430     -- the Cabal description file.
 431     . sortBy (comparing thisFirst)
 432     -- If the user has specified the repo kind, filter out the repositories
 433     -- they're not interested in.
 434     . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)
 435   where
 436     thisFirst :: PD.SourceRepo -> Int
 437     thisFirst r = case PD.repoKind r of
 438       RepoThis -> 0
 439       RepoHead -> case PD.repoTag r of
 440         -- If the type is 'head' but the author specified a tag, they
 441         -- probably meant to create a 'this' repository but screwed up.
 442         Just _ -> 0
 443         Nothing -> 1
 444       RepoKindUnknown _ -> 2