-----------------------------------------------------------------------------
-- |
-- 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.Compat.Directory
         ( listDirectory )
import Distribution.Package
         ( PackageId, packageId, packageName )
import Distribution.Simple.Setup
         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
         ( notice, die', info, writeFileAtomic )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Program
         ( programName )
import Distribution.Types.SourceRepo (RepoKind (..))
import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)

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
        ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos )
import Distribution.Solver.Types.SourcePackage

import qualified Data.Map as Map
import System.Directory
         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
import System.FilePath
         ( (</>), (<.>), addTrailingPathSeparator )


-- | Entry point for the 'cabal get' command.
get :: Verbosity
    -> RepoContext
    -> GlobalFlags
    -> GetFlags
    -> [UserTarget]
    -> IO ()
get :: Verbosity
-> RepoContext -> GlobalFlags -> GetFlags -> [UserTarget] -> IO ()
get Verbosity
verbosity RepoContext
_ GlobalFlags
_ GetFlags
_ [] =
    Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"No packages requested. Nothing to do."

get Verbosity
verbosity RepoContext
repoCtxt GlobalFlags
_ GetFlags
getFlags [UserTarget]
userTargets = do
  let useSourceRepo :: Bool
useSourceRepo = case GetFlags -> Flag (Maybe RepoKind)
getSourceRepository GetFlags
getFlags of
                        Flag (Maybe RepoKind)
NoFlag -> Bool
False
                        Flag (Maybe RepoKind)
_      -> Bool
True

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useSourceRepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    (UserTarget -> IO ()) -> [UserTarget] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> UserTarget -> IO ()
checkTarget Verbosity
verbosity) [UserTarget]
userTargets

  let idxState :: Maybe TotalIndexState
      idxState :: Maybe TotalIndexState
idxState = Flag TotalIndexState -> Maybe TotalIndexState
forall a. Flag a -> Maybe a
flagToMaybe (Flag TotalIndexState -> Maybe TotalIndexState)
-> Flag TotalIndexState -> Maybe TotalIndexState
forall a b. (a -> b) -> a -> b
$ GetFlags -> Flag TotalIndexState
getIndexState GetFlags
getFlags

      activeRepos :: Maybe ActiveRepos
      activeRepos :: Maybe ActiveRepos
activeRepos = Flag ActiveRepos -> Maybe ActiveRepos
forall a. Flag a -> Maybe a
flagToMaybe (Flag ActiveRepos -> Maybe ActiveRepos)
-> Flag ActiveRepos -> Maybe ActiveRepos
forall a b. (a -> b) -> a -> b
$ GetFlags -> Flag ActiveRepos
getActiveRepos GetFlags
getFlags

  (SourcePackageDb
sourcePkgDb, TotalIndexState
_, ActiveRepos
_) <- Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState Verbosity
verbosity RepoContext
repoCtxt Maybe TotalIndexState
idxState Maybe ActiveRepos
activeRepos

  [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers <- Verbosity
-> RepoContext
-> PackageIndex UnresolvedSourcePackage
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
forall pkg.
Package pkg =>
Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets Verbosity
verbosity RepoContext
repoCtxt
                   (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)
                   [UserTarget]
userTargets

  [UnresolvedSourcePackage]
pkgs <- ([ResolveNoDepsError] -> IO [UnresolvedSourcePackage])
-> ([UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage])
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> String -> IO [UnresolvedSourcePackage]
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO [UnresolvedSourcePackage])
-> ([ResolveNoDepsError] -> String)
-> [ResolveNoDepsError]
-> IO [UnresolvedSourcePackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([ResolveNoDepsError] -> [String])
-> [ResolveNoDepsError]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResolveNoDepsError -> String) -> [ResolveNoDepsError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ResolveNoDepsError -> String
forall a. Show a => a -> String
show) [UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [ResolveNoDepsError] [UnresolvedSourcePackage]
 -> IO [UnresolvedSourcePackage])
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
forall a b. (a -> b) -> a -> b
$
            DepResolverParams
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies
              (SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
resolverParams SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
prefix) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
prefix

  if Bool
useSourceRepo
    then [UnresolvedSourcePackage] -> IO ()
clone  [UnresolvedSourcePackage]
pkgs
    else [UnresolvedSourcePackage] -> IO ()
unpack [UnresolvedSourcePackage]
pkgs

  where
    resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
    resolverParams :: SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
resolverParams SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers =
        --TODO: add command-line constraint and preference args for unpack
        InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy InstalledPackageIndex
forall a. Monoid a => a
mempty SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers

    prefix :: String
    prefix :: String
prefix = String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"" (GetFlags -> Flag String
getDestDir GetFlags
getFlags)

    clone :: [UnresolvedSourcePackage] -> IO ()
    clone :: [UnresolvedSourcePackage] -> IO ()
clone = Verbosity
-> String -> Maybe RepoKind -> [(PackageId, [SourceRepo])] -> IO ()
clonePackagesFromSourceRepo Verbosity
verbosity String
prefix Maybe RepoKind
kind
          ([(PackageId, [SourceRepo])] -> IO ())
-> ([UnresolvedSourcePackage] -> [(PackageId, [SourceRepo])])
-> [UnresolvedSourcePackage]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnresolvedSourcePackage -> (PackageId, [SourceRepo]))
-> [UnresolvedSourcePackage] -> [(PackageId, [SourceRepo])]
forall a b. (a -> b) -> [a] -> [b]
map (\UnresolvedSourcePackage
pkg -> (UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg, UnresolvedSourcePackage -> [SourceRepo]
forall loc. SourcePackage loc -> [SourceRepo]
packageSourceRepos UnresolvedSourcePackage
pkg))
      where
        kind :: Maybe RepoKind
        kind :: Maybe RepoKind
kind = Flag (Maybe RepoKind) -> Maybe RepoKind
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (Maybe RepoKind) -> Maybe RepoKind)
-> (GetFlags -> Flag (Maybe RepoKind))
-> GetFlags
-> Maybe RepoKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetFlags -> Flag (Maybe RepoKind)
getSourceRepository (GetFlags -> Maybe RepoKind) -> GetFlags -> Maybe RepoKind
forall a b. (a -> b) -> a -> b
$ GetFlags
getFlags
        packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]
        packageSourceRepos :: SourcePackage loc -> [SourceRepo]
packageSourceRepos = PackageDescription -> [SourceRepo]
PD.sourceRepos
                           (PackageDescription -> [SourceRepo])
-> (SourcePackage loc -> PackageDescription)
-> SourcePackage loc
-> [SourceRepo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
PD.packageDescription
                           (GenericPackageDescription -> PackageDescription)
-> (SourcePackage loc -> GenericPackageDescription)
-> SourcePackage loc
-> PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePackage loc -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription

    unpack :: [UnresolvedSourcePackage] -> IO ()
    unpack :: [UnresolvedSourcePackage] -> IO ()
unpack [UnresolvedSourcePackage]
pkgs = do
      [UnresolvedSourcePackage]
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [UnresolvedSourcePackage]
pkgs ((UnresolvedSourcePackage -> IO ()) -> IO ())
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UnresolvedSourcePackage
pkg -> do
        ResolvedPkgLoc
location <- Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage Verbosity
verbosity RepoContext
repoCtxt (UnresolvedSourcePackage -> UnresolvedPkgLoc
forall loc. SourcePackage loc -> loc
srcpkgSource UnresolvedSourcePackage
pkg)
        let pkgid :: PackageId
pkgid = UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg
            descOverride :: Maybe ByteString
descOverride | Bool
usePristine = Maybe ByteString
forall a. Maybe a
Nothing
                         | Bool
otherwise   = UnresolvedSourcePackage -> Maybe ByteString
forall loc. SourcePackage loc -> Maybe ByteString
srcpkgDescrOverride UnresolvedSourcePackage
pkg
        case ResolvedPkgLoc
location of
          LocalTarballPackage String
tarballPath ->
            Verbosity
-> String -> PackageId -> Maybe ByteString -> String -> IO ()
unpackPackage Verbosity
verbosity String
prefix PackageId
pkgid Maybe ByteString
descOverride String
tarballPath

          RemoteTarballPackage URI
_tarballURL String
tarballPath ->
            Verbosity
-> String -> PackageId -> Maybe ByteString -> String -> IO ()
unpackPackage Verbosity
verbosity String
prefix PackageId
pkgid Maybe ByteString
descOverride String
tarballPath

          RepoTarballPackage Repo
_repo PackageId
_pkgid String
tarballPath ->
            Verbosity
-> String -> PackageId -> Maybe ByteString -> String -> IO ()
unpackPackage Verbosity
verbosity String
prefix PackageId
pkgid Maybe ByteString
descOverride String
tarballPath

          RemoteSourceRepoPackage SourceRepoMaybe
_repo String
_ ->
            Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"The 'get' command does no yet support targets "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"that are remote source repositories."

          LocalUnpackedPackage String
_ ->
            String -> IO ()
forall a. HasCallStack => String -> a
error String
"Distribution.Client.Get.unpack: the impossible happened."
      where
        usePristine :: Bool
        usePristine :: Bool
usePristine = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (GetFlags -> Flag Bool
getPristine GetFlags
getFlags)

checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget Verbosity
verbosity UserTarget
target = case UserTarget
target of
    UserTargetLocalDir       String
dir  -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> String
notTarball String
dir)
    UserTargetLocalCabalFile String
file -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> String
notTarball String
file)
    UserTarget
_                             -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    notTarball :: String -> String
notTarball String
t =
        String
"The 'get' command is for tarball packages. "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The target '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a tarball."

-- ------------------------------------------------------------
-- * Unpacking the source tarball
-- ------------------------------------------------------------

unpackPackage :: Verbosity -> FilePath -> PackageId
              -> PackageDescriptionOverride
              -> FilePath  -> IO ()
unpackPackage :: Verbosity
-> String -> PackageId -> Maybe ByteString -> String -> IO ()
unpackPackage Verbosity
verbosity String
prefix PackageId
pkgid Maybe ByteString
descOverride String
pkgPath = do
    let pkgdirname :: String
pkgdirname               = PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
        pkgdir :: String
pkgdir                   = String
prefix String -> String -> String
</> String
pkgdirname
        pkgdir' :: String
pkgdir'                  = String -> String
addTrailingPathSeparator String
pkgdir
        emptyDirectory :: String -> IO Bool
emptyDirectory String
directory = [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
directory
    Bool
existsDir  <- String -> IO Bool
doesDirectoryExist String
pkgdir
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
existsDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
isEmpty <- String -> IO Bool
emptyDirectory String
pkgdir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isEmpty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"The directory \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgdir' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" already exists and is not empty, not unpacking."
    Bool
existsFile  <- String -> IO Bool
doesFileExist String
pkgdir
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
existsFile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
     String
"A file \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" is in the way, not unpacking."
    Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unpacking to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgdir'
    String -> String -> String -> IO ()
Tar.extractTarGzFile String
prefix String
pkgdirname String
pkgPath

    case Maybe ByteString
descOverride of
      Maybe ByteString
Nothing     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just ByteString
pkgtxt -> do
        let descFilePath :: String
descFilePath = String
pkgdir String -> String -> String
</> PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgid) String -> String -> String
<.> String
"cabal"
        Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Updating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
descFilePath
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with the latest revision from the index."
        String -> ByteString -> IO ()
writeFileAtomic String
descFilePath ByteString
pkgtxt


-- ------------------------------------------------------------
-- * Cloning packages from their declared source repositories
-- ------------------------------------------------------------


data ClonePackageException =
       ClonePackageNoSourceRepos       PackageId
     | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
     | ClonePackageNoRepoType          PackageId PD.SourceRepo
     | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
     | ClonePackageNoRepoLocation      PackageId PD.SourceRepo
     | ClonePackageDestinationExists   PackageId FilePath Bool
     | ClonePackageFailedWithExitCode  PackageId SourceRepoProxy String ExitCode
  deriving (Int -> ClonePackageException -> String -> String
[ClonePackageException] -> String -> String
ClonePackageException -> String
(Int -> ClonePackageException -> String -> String)
-> (ClonePackageException -> String)
-> ([ClonePackageException] -> String -> String)
-> Show ClonePackageException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ClonePackageException] -> String -> String
$cshowList :: [ClonePackageException] -> String -> String
show :: ClonePackageException -> String
$cshow :: ClonePackageException -> String
showsPrec :: Int -> ClonePackageException -> String -> String
$cshowsPrec :: Int -> ClonePackageException -> String -> String
Show, ClonePackageException -> ClonePackageException -> Bool
(ClonePackageException -> ClonePackageException -> Bool)
-> (ClonePackageException -> ClonePackageException -> Bool)
-> Eq ClonePackageException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClonePackageException -> ClonePackageException -> Bool
$c/= :: ClonePackageException -> ClonePackageException -> Bool
== :: ClonePackageException -> ClonePackageException -> Bool
$c== :: ClonePackageException -> ClonePackageException -> Bool
Eq)

instance Exception ClonePackageException where
  displayException :: ClonePackageException -> String
displayException (ClonePackageNoSourceRepos PackageId
pkgid) =
       String
"Cannot fetch a source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The package does not specify any source repositories."

  displayException (ClonePackageNoSourceReposOfKind PackageId
pkgid Maybe RepoKind
repoKind) =
       String
"Cannot fetch a source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The package does not specify a source repository of the requested "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"kind" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (RepoKind -> String) -> Maybe RepoKind -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"." (\RepoKind
k -> String
" (kind " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoKind -> String
forall a. Pretty a => a -> String
prettyShow RepoKind
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
").") Maybe RepoKind
repoKind

  displayException (ClonePackageNoRepoType PackageId
pkgid SourceRepo
_repo) =
       String
"Cannot fetch the source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The package's description specifies a source repository but does "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"not specify the repository 'type' field (e.g. git, darcs or hg)."

  displayException (ClonePackageUnsupportedRepoType PackageId
pkgid SourceRepoProxy
_ RepoType
repoType) =
       String
"Cannot fetch the source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The repository type '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoType -> String
forall a. Pretty a => a -> String
prettyShow RepoType
repoType
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not yet supported."

  displayException (ClonePackageNoRepoLocation PackageId
pkgid SourceRepo
_repo) =
       String
"Cannot fetch the source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The package's description specifies a source repository but does "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"not specify the repository 'location' field (i.e. the URL)."

  displayException (ClonePackageDestinationExists PackageId
pkgid String
dest Bool
isdir) =
       String
"Not fetching the source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
isdir then String
"The destination directory " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already exists."
                else String
"A file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is in the way."

  displayException (ClonePackageFailedWithExitCode
                      PackageId
pkgid SourceRepoProxy
repo String
vcsprogname ExitCode
exitcode) =
       String
"Failed to fetch the source repository for package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", repository location " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceRepoProxy -> String
forall (f :: * -> *). SourceRepositoryPackage f -> String
srpLocation SourceRepoProxy
repo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ("
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vcsprogname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")."


-- | 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, [PD.SourceRepo])]
                                                   -- ^ the packages and their
                                                   -- available 'SourceRepo's
                            -> IO ()
clonePackagesFromSourceRepo :: Verbosity
-> String -> Maybe RepoKind -> [(PackageId, [SourceRepo])] -> IO ()
clonePackagesFromSourceRepo Verbosity
verbosity String
destDirPrefix
                            Maybe RepoKind
preferredRepoKind [(PackageId, [SourceRepo])]
pkgrepos = do

    -- Do a bunch of checks and collect the required info
    [(PackageId, SourceRepoMaybe, VCS Program, String)]
pkgrepos' <- ((PackageId, [SourceRepo])
 -> IO (PackageId, SourceRepoMaybe, VCS Program, String))
-> [(PackageId, [SourceRepo])]
-> IO [(PackageId, SourceRepoMaybe, VCS Program, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PackageId, [SourceRepo])
-> IO (PackageId, SourceRepoMaybe, VCS Program, String)
preCloneChecks [(PackageId, [SourceRepo])]
pkgrepos

    -- Configure the VCS drivers for all the repository types we may need
    Map RepoType (VCS ConfiguredProgram)
vcss <- Verbosity
-> Map RepoType (VCS Program)
-> IO (Map RepoType (VCS ConfiguredProgram))
configureVCSs Verbosity
verbosity (Map RepoType (VCS Program)
 -> IO (Map RepoType (VCS ConfiguredProgram)))
-> Map RepoType (VCS Program)
-> IO (Map RepoType (VCS ConfiguredProgram))
forall a b. (a -> b) -> a -> b
$
              [(RepoType, VCS Program)] -> Map RepoType (VCS Program)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (VCS Program -> RepoType
forall program. VCS program -> RepoType
vcsRepoType VCS Program
vcs, VCS Program
vcs)
                           | (PackageId
_, SourceRepoMaybe
_, VCS Program
vcs, String
_) <- [(PackageId, SourceRepoMaybe, VCS Program, String)]
pkgrepos' ]

    -- Now execute all the required commands for each repo
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [ Verbosity
-> VCS ConfiguredProgram -> SourceRepoMaybe -> String -> IO ()
forall (f :: * -> *).
Verbosity
-> VCS ConfiguredProgram
-> SourceRepositoryPackage f
-> String
-> IO ()
cloneSourceRepo Verbosity
verbosity VCS ConfiguredProgram
vcs' SourceRepoMaybe
repo String
destDir
          IO () -> (ExitCode -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \ExitCode
exitcode ->
           ClonePackageException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (PackageId
-> SourceRepoProxy -> String -> ExitCode -> ClonePackageException
ClonePackageFailedWithExitCode
                      PackageId
pkgid (SourceRepoMaybe -> SourceRepoProxy
forall (f :: * -> *). SourceRepositoryPackage f -> SourceRepoProxy
srpToProxy SourceRepoMaybe
repo) (Program -> String
programName (VCS Program -> Program
forall program. VCS program -> program
vcsProgram VCS Program
vcs)) ExitCode
exitcode)
      | (PackageId
pkgid, SourceRepoMaybe
repo, VCS Program
vcs, String
destDir) <- [(PackageId, SourceRepoMaybe, VCS Program, String)]
pkgrepos'
      , let vcs' :: VCS ConfiguredProgram
vcs' = VCS ConfiguredProgram
-> RepoType
-> Map RepoType (VCS ConfiguredProgram)
-> VCS ConfiguredProgram
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> VCS ConfiguredProgram
forall a. HasCallStack => String -> a
error (String -> VCS ConfiguredProgram)
-> String -> VCS ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ String
"Cannot configure " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoType -> String
forall a. Pretty a => a -> String
prettyShow (VCS Program -> RepoType
forall program. VCS program -> RepoType
vcsRepoType VCS Program
vcs)) (VCS Program -> RepoType
forall program. VCS program -> RepoType
vcsRepoType VCS Program
vcs) Map RepoType (VCS ConfiguredProgram)
vcss
      ]

  where
    preCloneChecks :: (PackageId, [PD.SourceRepo])
                   -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
    preCloneChecks :: (PackageId, [SourceRepo])
-> IO (PackageId, SourceRepoMaybe, VCS Program, String)
preCloneChecks (PackageId
pkgid, [SourceRepo]
repos) = do
      SourceRepo
repo <- case Maybe RepoKind -> [SourceRepo] -> Maybe SourceRepo
selectPackageSourceRepo Maybe RepoKind
preferredRepoKind [SourceRepo]
repos of
        Just SourceRepo
repo            -> SourceRepo -> IO SourceRepo
forall (m :: * -> *) a. Monad m => a -> m a
return SourceRepo
repo
        Maybe SourceRepo
Nothing | [SourceRepo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SourceRepo]
repos -> ClonePackageException -> IO SourceRepo
forall e a. Exception e => e -> IO a
throwIO (PackageId -> ClonePackageException
ClonePackageNoSourceRepos PackageId
pkgid)
        Maybe SourceRepo
Nothing              -> ClonePackageException -> IO SourceRepo
forall e a. Exception e => e -> IO a
throwIO (PackageId -> Maybe RepoKind -> ClonePackageException
ClonePackageNoSourceReposOfKind
                                           PackageId
pkgid Maybe RepoKind
preferredRepoKind)

      (SourceRepoMaybe
repo', VCS Program
vcs) <- case SourceRepo
-> Either
     SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
validatePDSourceRepo SourceRepo
repo of
        Right (SourceRepoMaybe
repo', String
_, RepoType
_, VCS Program
vcs) -> (SourceRepoMaybe, VCS Program) -> IO (SourceRepoMaybe, VCS Program)
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceRepoMaybe
repo', VCS Program
vcs)
        Left SourceRepoProblem
SourceRepoRepoTypeUnspecified ->
          ClonePackageException -> IO (SourceRepoMaybe, VCS Program)
forall e a. Exception e => e -> IO a
throwIO (PackageId -> SourceRepo -> ClonePackageException
ClonePackageNoRepoType PackageId
pkgid SourceRepo
repo)

        Left (SourceRepoRepoTypeUnsupported SourceRepoProxy
repo' RepoType
repoType) ->
          ClonePackageException -> IO (SourceRepoMaybe, VCS Program)
forall e a. Exception e => e -> IO a
throwIO (PackageId -> SourceRepoProxy -> RepoType -> ClonePackageException
ClonePackageUnsupportedRepoType PackageId
pkgid SourceRepoProxy
repo' RepoType
repoType)

        Left SourceRepoProblem
SourceRepoLocationUnspecified ->
          ClonePackageException -> IO (SourceRepoMaybe, VCS Program)
forall e a. Exception e => e -> IO a
throwIO (PackageId -> SourceRepo -> ClonePackageException
ClonePackageNoRepoLocation PackageId
pkgid SourceRepo
repo)

      let destDir :: FilePath
          destDir :: String
destDir = String
destDirPrefix String -> String -> String
</> PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgid)
      Bool
destDirExists  <- String -> IO Bool
doesDirectoryExist String
destDir
      Bool
destFileExists <- String -> IO Bool
doesFileExist      String
destDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
destDirExists Bool -> Bool -> Bool
|| Bool
destFileExists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ClonePackageException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (PackageId -> String -> Bool -> ClonePackageException
ClonePackageDestinationExists PackageId
pkgid String
destDir Bool
destDirExists)

      (PackageId, SourceRepoMaybe, VCS Program, String)
-> IO (PackageId, SourceRepoMaybe, VCS Program, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId
pkgid, SourceRepoMaybe
repo', VCS Program
vcs, String
destDir)

-------------------------------------------------------------------------------
-- Selecting
-------------------------------------------------------------------------------

-- | Pick the 'SourceRepo' to use to get the package sources from.
--
-- Note that this does /not/ depend on what 'VCS' drivers we are able to
-- successfully configure. It is based only on the 'SourceRepo's declared
-- in the package, and optionally on a preferred 'RepoKind'.
--
selectPackageSourceRepo :: Maybe RepoKind
                        -> [PD.SourceRepo]
                        -> Maybe PD.SourceRepo
selectPackageSourceRepo :: Maybe RepoKind -> [SourceRepo] -> Maybe SourceRepo
selectPackageSourceRepo Maybe RepoKind
preferredRepoKind =
    [SourceRepo] -> Maybe SourceRepo
forall a. [a] -> Maybe a
listToMaybe
    -- Sort repositories by kind, from This to Head to Unknown. Repositories
    -- with equivalent kinds are selected based on the order they appear in
    -- the Cabal description file.
  ([SourceRepo] -> Maybe SourceRepo)
-> ([SourceRepo] -> [SourceRepo])
-> [SourceRepo]
-> Maybe SourceRepo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceRepo -> SourceRepo -> Ordering)
-> [SourceRepo] -> [SourceRepo]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((SourceRepo -> Int) -> SourceRepo -> SourceRepo -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SourceRepo -> Int
thisFirst)
    -- If the user has specified the repo kind, filter out the repositories
    -- they're not interested in.
  ([SourceRepo] -> [SourceRepo])
-> ([SourceRepo] -> [SourceRepo]) -> [SourceRepo] -> [SourceRepo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceRepo -> Bool) -> [SourceRepo] -> [SourceRepo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SourceRepo
repo -> Bool -> (RepoKind -> Bool) -> Maybe RepoKind -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (SourceRepo -> RepoKind
PD.repoKind SourceRepo
repo RepoKind -> RepoKind -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe RepoKind
preferredRepoKind)
  where
    thisFirst :: PD.SourceRepo -> Int
    thisFirst :: SourceRepo -> Int
thisFirst SourceRepo
r = case SourceRepo -> RepoKind
PD.repoKind SourceRepo
r of
        RepoKind
RepoThis -> Int
0
        RepoKind
RepoHead -> case SourceRepo -> Maybe String
PD.repoTag SourceRepo
r of
            -- If the type is 'head' but the author specified a tag, they
            -- probably meant to create a 'this' repository but screwed up.
            Just String
_  -> Int
0
            Maybe String
Nothing -> Int
1
        RepoKindUnknown String
_ -> Int
2