module Distribution.Client.Get (
get,
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 )
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 =
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."
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
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
")."
clonePackagesFromSourceRepo :: Verbosity
-> FilePath
-> Maybe RepoKind
-> [(PackageId, [PD.SourceRepo])]
-> IO ()
clonePackagesFromSourceRepo :: Verbosity
-> String -> Maybe RepoKind -> [(PackageId, [SourceRepo])] -> IO ()
clonePackagesFromSourceRepo Verbosity
verbosity String
destDirPrefix
Maybe RepoKind
preferredRepoKind [(PackageId, [SourceRepo])]
pkgrepos = do
[(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
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' ]
[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)
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
([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)
([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
Just String
_ -> Int
0
Maybe String
Nothing -> Int
1
RepoKindUnknown String
_ -> Int
2