----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Get -- Copyright : (c) Andrea Vezzosi 2008 -- Duncan Coutts 2011 -- John Millikin 2012 -- License : BSD-like -- -- Maintainer : cabal-devel@haskell.org -- Stability : provisional -- Portability : portable -- -- The 'cabal get' command. ----------------------------------------------------------------------------- module Distribution.Client.Get ( get, -- * Cloning 'SourceRepo's -- | Mainly exported for testing purposes clonePackagesFromSourceRepo, ClonePackageException(..), ) where import Prelude () import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Package ( PackageId, packageId, packageName ) import Distribution.Simple.Setup ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils ( notice, die', info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text (display) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName ) import Distribution.Client.Setup ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.Dependency import Distribution.Client.VCS import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackagesAtIndexState ) import Distribution.Solver.Types.SourcePackage import Control.Exception ( Exception(..), catch, throwIO ) import Control.Monad ( mapM, forM_, mapM_ ) import qualified Data.Map as Map import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) import System.Exit ( ExitCode(..) ) import System.FilePath ( (), (<.>), addTrailingPathSeparator ) -- | Entry point for the 'cabal get' command. get :: Verbosity -> RepoContext -> GlobalFlags -> GetFlags -> [UserTarget] -> IO () get verbosity _ _ _ [] = notice verbosity "No packages requested. Nothing to do." get verbosity repoCtxt globalFlags getFlags userTargets = do let useSourceRepo = case getSourceRepository getFlags of NoFlag -> False _ -> True unless useSourceRepo $ mapM_ (checkTarget verbosity) userTargets let idxState = flagToMaybe $ getIndexState getFlags sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState pkgSpecifiers <- resolveUserTargets verbosity repoCtxt (fromFlag $ globalWorldFile globalFlags) (packageIndex sourcePkgDb) userTargets pkgs <- either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) unless (null prefix) $ createDirectoryIfMissing True prefix if useSourceRepo then clone pkgs else unpack pkgs where resolverParams sourcePkgDb pkgSpecifiers = --TODO: add command-line constraint and preference args for unpack standardInstallPolicy mempty sourcePkgDb pkgSpecifiers prefix = fromFlagOrDefault "" (getDestDir getFlags) clone :: [UnresolvedSourcePackage] -> IO () clone = clonePackagesFromSourceRepo verbosity prefix kind . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind = fromFlag . getSourceRepository $ getFlags packageSourceRepos :: SourcePackage loc -> [SourceRepo] packageSourceRepos = PD.sourceRepos . PD.packageDescription . packageDescription unpack :: [UnresolvedSourcePackage] -> IO () unpack pkgs = do forM_ pkgs $ \pkg -> do location <- fetchPackage verbosity repoCtxt (packageSource pkg) let pkgid = packageId pkg descOverride | usePristine = Nothing | otherwise = packageDescrOverride pkg case location of LocalTarballPackage tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath RemoteTarballPackage _tarballURL tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath RepoTarballPackage _repo _pkgid tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath RemoteSourceRepoPackage _repo _ -> die' verbosity $ "The 'get' command does no yet support targets " ++ "that are remote source repositories." LocalUnpackedPackage _ -> error "Distribution.Client.Get.unpack: the impossible happened." where usePristine = fromFlagOrDefault False (getPristine getFlags) checkTarget :: Verbosity -> UserTarget -> IO () checkTarget verbosity target = case target of UserTargetLocalDir dir -> die' verbosity (notTarball dir) UserTargetLocalCabalFile file -> die' verbosity (notTarball file) _ -> return () where notTarball t = "The 'get' command is for tarball packages. " ++ "The target '" ++ t ++ "' is not a tarball." -- ------------------------------------------------------------ -- * Unpacking the source tarball -- ------------------------------------------------------------ unpackPackage :: Verbosity -> FilePath -> PackageId -> PackageDescriptionOverride -> FilePath -> IO () unpackPackage verbosity prefix pkgid descOverride pkgPath = do let pkgdirname = display pkgid pkgdir = prefix pkgdirname pkgdir' = addTrailingPathSeparator pkgdir existsDir <- doesDirectoryExist pkgdir when existsDir $ die' verbosity $ "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." existsFile <- doesFileExist pkgdir when existsFile $ die' verbosity $ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath case descOverride of Nothing -> return () Just pkgtxt -> do let descFilePath = pkgdir display (packageName pkgid) <.> "cabal" info verbosity $ "Updating " ++ descFilePath ++ " with the latest revision from the index." writeFileAtomic descFilePath pkgtxt -- ------------------------------------------------------------ -- * Cloning packages from their declared source repositories -- ------------------------------------------------------------ data ClonePackageException = ClonePackageNoSourceRepos PackageId | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) | ClonePackageNoRepoType PackageId SourceRepo | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType | ClonePackageNoRepoLocation PackageId SourceRepo | ClonePackageDestinationExists PackageId FilePath Bool | ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode deriving (Show, Eq) instance Exception ClonePackageException where displayException (ClonePackageNoSourceRepos pkgid) = "Cannot fetch a source repository for package " ++ display pkgid ++ ". The package does not specify any source repositories." displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = "Cannot fetch a source repository for package " ++ display pkgid ++ ". The package does not specify a source repository of the requested " ++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind displayException (ClonePackageNoRepoType pkgid _repo) = "Cannot fetch the source repository for package " ++ display pkgid ++ ". The package's description specifies a source repository but does " ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = "Cannot fetch the source repository for package " ++ display pkgid ++ ". The repository type '" ++ display repoType ++ "' is not yet supported." displayException (ClonePackageNoRepoLocation pkgid _repo) = "Cannot fetch the source repository for package " ++ display pkgid ++ ". The package's description specifies a source repository but does " ++ "not specify the repository 'location' field (i.e. the URL)." displayException (ClonePackageDestinationExists pkgid dest isdir) = "Not fetching the source repository for package " ++ display pkgid ++ ". " ++ if isdir then "The destination directory " ++ dest ++ " already exists." else "A file " ++ dest ++ " is in the way." displayException (ClonePackageFailedWithExitCode pkgid repo vcsprogname exitcode) = "Failed to fetch the source repository for package " ++ display pkgid ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " (" ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." -- | Given a bunch of package ids and their corresponding available -- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into -- new subdirs of the given directory. -- clonePackagesFromSourceRepo :: Verbosity -> FilePath -- ^ destination dir prefix -> Maybe RepoKind -- ^ preferred 'RepoKind' -> [(PackageId, [SourceRepo])] -- ^ the packages and their -- available 'SourceRepo's -> IO () clonePackagesFromSourceRepo verbosity destDirPrefix preferredRepoKind pkgrepos = do -- Do a bunch of checks and collect the required info pkgrepos' <- mapM preCloneChecks pkgrepos -- Configure the VCS drivers for all the repository types we may need vcss <- configureVCSs verbosity $ Map.fromList [ (vcsRepoType vcs, vcs) | (_, _, vcs, _) <- pkgrepos' ] -- Now execute all the required commands for each repo sequence_ [ cloneSourceRepo verbosity vcs' repo destDir `catch` \exitcode -> throwIO (ClonePackageFailedWithExitCode pkgid repo (programName (vcsProgram vcs)) exitcode) | (pkgid, repo, vcs, destDir) <- pkgrepos' , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss ] where preCloneChecks :: (PackageId, [SourceRepo]) -> IO (PackageId, SourceRepo, VCS Program, FilePath) preCloneChecks (pkgid, repos) = do repo <- case selectPackageSourceRepo preferredRepoKind repos of Just repo -> return repo Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) Nothing -> throwIO (ClonePackageNoSourceReposOfKind pkgid preferredRepoKind) vcs <- case validateSourceRepo repo of Right (_, _, _, vcs) -> return vcs Left SourceRepoRepoTypeUnspecified -> throwIO (ClonePackageNoRepoType pkgid repo) Left (SourceRepoRepoTypeUnsupported repoType) -> throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType) Left SourceRepoLocationUnspecified -> throwIO (ClonePackageNoRepoLocation pkgid repo) let destDir = destDirPrefix display (packageName pkgid) destDirExists <- doesDirectoryExist destDir destFileExists <- doesFileExist destDir when (destDirExists || destFileExists) $ throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) return (pkgid, repo, vcs, destDir)