-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

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

import Distribution.Client.Dependency
import Distribution.Client.FetchUtils
import Distribution.Client.IndexUtils
  ( ActiveRepos
  , TotalIndexState
  , getSourcePackagesAtIndexState
  )
import Distribution.Client.Setup
  ( GetFlags (..)
  , GlobalFlags (..)
  , RepoContext (..)
  )
import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.Targets
import Distribution.Client.Types
import Distribution.Client.VCS
import Distribution.PackageDescription.PrettyPrint
  ( writeGenericPackageDescription
  )
import Distribution.Solver.Types.SourcePackage

import Control.Monad (mapM_)
import qualified Data.Map as Map
import Distribution.Client.Errors
import Distribution.Utils.NubList
  ( fromNubList
  )
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
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 -> CabalInstallException -> IO [UnresolvedSourcePackage]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO [UnresolvedSourcePackage])
-> ([ResolveNoDepsError] -> CabalInstallException)
-> [ResolveNoDepsError]
-> IO [UnresolvedSourcePackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> CabalInstallException
PkgSpecifierException ([String] -> CabalInstallException)
-> ([ResolveNoDepsError] -> [String])
-> [ResolveNoDepsError]
-> CabalInstallException
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 a. a -> IO a
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 a. [a] -> 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
onlyPkgDescr
    then do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useSourceRepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Ignoring --source-repository for --only-package-description"

      (UnresolvedSourcePackage -> IO ())
-> [UnresolvedSourcePackage] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Verbosity -> String -> UnresolvedSourcePackage -> IO ()
unpackOnlyPkgDescr Verbosity
verbosity String
prefix) [UnresolvedSourcePackage]
pkgs
    else
      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

    onlyPkgDescr :: Bool
onlyPkgDescr = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (GetFlags -> Flag Bool
getOnlyPkgDescr GetFlags
getFlags)

    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
-> [String]
-> [(PackageId, [SourceRepo])]
-> IO ()
clonePackagesFromSourceRepo Verbosity
verbosity String
prefix Maybe RepoKind
kind (NubList String -> [String]
forall a. NubList a -> [a]
fromNubList (NubList String -> [String]) -> NubList String -> [String]
forall a b. (a -> b) -> a -> b
$ GlobalFlags -> NubList String
globalProgPathExtra GlobalFlags
globalFlags)
        ([(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 :: forall loc. 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 -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
UnpackGet
          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 -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
NotTarballDir String
dir
  UserTargetLocalCabalFile String
file -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
NotTarballDir String
file
  UserTarget
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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
-> 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 a. [a] -> 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 -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> CabalInstallException
DirectoryAlreadyExists String
pkgdir'
  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 -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> CabalInstallException
FileExists String
pkgdir
  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 a. a -> IO a
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

-- | Write a @pkgId.cabal@ file with the package description to the destination
-- directory, unless one already exists.
unpackOnlyPkgDescr :: Verbosity -> FilePath -> UnresolvedSourcePackage -> IO ()
unpackOnlyPkgDescr :: Verbosity -> String -> UnresolvedSourcePackage -> IO ()
unpackOnlyPkgDescr Verbosity
verbosity String
dstDir UnresolvedSourcePackage
pkg = do
  let pkgFile :: String
pkgFile = String
dstDir String -> String -> String
</> PackageId -> String
forall a. Pretty a => a -> String
prettyShow (UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg) String -> String -> String
<.> String
"cabal"
  Bool
existsFile <- String -> IO Bool
doesFileExist String
pkgFile
  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 -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> CabalInstallException
FileAlreadyExists String
pkgFile
  Bool
existsDir <- String -> IO Bool
doesDirectoryExist (String -> String
addTrailingPathSeparator String
pkgFile)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
existsDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> CabalInstallException
DirectoryExists String
pkgFile
  Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Writing package description to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgFile
  case UnresolvedSourcePackage -> Maybe ByteString
forall loc. SourcePackage loc -> Maybe ByteString
srcpkgDescrOverride UnresolvedSourcePackage
pkg of
    Just ByteString
pkgTxt -> String -> ByteString -> IO ()
writeFileAtomic String
pkgFile ByteString
pkgTxt
    Maybe ByteString
Nothing ->
      String -> GenericPackageDescription -> IO ()
writeGenericPackageDescription String
pkgFile (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg)

-- ------------------------------------------------------------

-- * 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
$cshowsPrec :: Int -> ClonePackageException -> String -> String
showsPrec :: Int -> ClonePackageException -> String -> String
$cshow :: ClonePackageException -> String
show :: ClonePackageException -> String
$cshowList :: [ClonePackageException] -> String -> String
showList :: [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
$c== :: ClonePackageException -> ClonePackageException -> Bool
== :: ClonePackageException -> ClonePackageException -> Bool
$c/= :: ClonePackageException -> ClonePackageException -> Bool
/= :: 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'
  -> [FilePath]
  -- ^ Extra prog paths
  -> [(PackageId, [PD.SourceRepo])]
  -- ^ the packages and their
  -- available 'SourceRepo's
  -> IO ()
clonePackagesFromSourceRepo :: Verbosity
-> String
-> Maybe RepoKind
-> [String]
-> [(PackageId, [SourceRepo])]
-> IO ()
clonePackagesFromSourceRepo
  Verbosity
verbosity
  String
destDirPrefix
  Maybe RepoKind
preferredRepoKind
  [String]
progPaths
  [(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
-> [String]
-> Map RepoType (VCS Program)
-> IO (Map RepoType (VCS ConfiguredProgram))
configureVCSs Verbosity
verbosity [String]
progPaths (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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SourceRepo
repo
          Maybe SourceRepo
Nothing | [SourceRepo] -> Bool
forall a. [a] -> 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 a. a -> IO a
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 a. a -> IO a
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