{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Pantry.Repo
  ( fetchReposRaw
  , fetchRepos
  , getRepo
  , getRepoKey
  , createRepoArchive
  , withRepoArchive
  , withRepo
  ) where

import           Database.Persist ( Entity (..) )
import           Pantry.Archive
import           Pantry.Storage hiding ( findOrGenerateCabalFile )
import           Pantry.Types
import           Path.IO ( resolveFile' )
import           RIO
import           RIO.ByteString ( isInfixOf )
import           RIO.ByteString.Lazy ( toStrict )
import           RIO.Directory ( doesDirectoryExist )
import           RIO.FilePath ( (</>) )
import qualified RIO.Map as Map
import           RIO.Process
import qualified RIO.Text as T
import           System.Console.ANSI ( hSupportsANSIWithoutEmulation )
import           System.IsWindows ( osIsWindows )

data TarType = Gnu | Bsd

getGitTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType
getGitTarType :: forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getGitTarType = if Bool
osIsWindows
  then do
    (ExitCode
_, ByteString
stdoutBS, ByteString
_) <- forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"git" [FilePath
"--version"] forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess
    let bs :: ByteString
bs = ByteString -> ByteString
toStrict ByteString
stdoutBS
    -- If using Git for Windows, then assume that the tar type within

    -- `git submodule foreach <command>` is the Git-supplied\MSYS2-supplied

    -- GNU tar

    if ByteString
"windows" ByteString -> ByteString -> Bool
`isInfixOf` ByteString
bs then forall (f :: * -> *) a. Applicative f => a -> f a
pure TarType
Gnu else forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getTarType
  else forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getTarType

getTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType
getTarType :: forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getTarType = do
  (ExitCode
_, ByteString
stdoutBS, ByteString
_) <- forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"tar" [FilePath
"--version"] forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess
  let bs :: ByteString
bs = ByteString -> ByteString
toStrict ByteString
stdoutBS
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if ByteString
"GNU" ByteString -> ByteString -> Bool
`isInfixOf` ByteString
bs then TarType
Gnu else TarType
Bsd

-- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of

-- 'PackageMetadata'.

--

-- @since 0.5.3

fetchReposRaw ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => [(Repo, RawPackageMetadata)]
  -> RIO env ()
fetchReposRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw [(Repo, RawPackageMetadata)]
pairs = do
  let repos :: [AggregateRepo]
repos = [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos [(Repo, RawPackageMetadata)]
pairs
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (forall a. Show a => a -> Utf8Builder
displayShow [AggregateRepo]
repos)
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [AggregateRepo]
repos forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
AggregateRepo -> RIO env [Package]
getRepos

-- | Fetch the given repositories at once and populate the pantry database.

--

-- @since 0.5.3

fetchRepos ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => [(Repo, PackageMetadata)]
  -> RIO env ()
fetchRepos :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, PackageMetadata)] -> RIO env ()
fetchRepos [(Repo, PackageMetadata)]
pairs = do
  -- TODO be more efficient, group together shared archives

  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second PackageMetadata -> RawPackageMetadata
toRawPM) [(Repo, PackageMetadata)]
pairs

getRepoKey ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Repo
  -> RawPackageMetadata
  -> RIO env TreeKey
getRepoKey :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env TreeKey
getRepoKey Repo
repo RawPackageMetadata
rpm = Package -> TreeKey
packageTreeKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
rpm -- potential optimization


getRepo ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Repo
  -> RawPackageMetadata
  -> RIO env Package
getRepo :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
pm = do
  RIO env Package -> RIO env Package
withCache forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo' Repo
repo RawPackageMetadata
pm
 where
  withCache :: RIO env Package -> RIO env Package
  withCache :: RIO env Package -> RIO env Package
withCache RIO env Package
inner = do
    Maybe TreeId
mtid <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (forall env. Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache Repo
repo)
    case Maybe TreeId
mtid of
      Just TreeId
tid -> forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById (Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo Repo
repo RawPackageMetadata
pm) TreeId
tid
      Maybe TreeId
Nothing -> do
        Package
package <- RIO env Package
inner
        forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
          Maybe (Entity Tree)
ment <- forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey forall a b. (a -> b) -> a -> b
$ Package -> TreeKey
packageTreeKey Package
package
          case Maybe (Entity Tree)
ment of
            Maybe (Entity Tree)
Nothing ->  forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$
                FilePath
"invariant violated, Tree not found: "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (Package -> TreeKey
packageTreeKey Package
package)
            Just (Entity TreeId
tid Tree
_) -> forall env.
Repo -> Text -> TreeId -> ReaderT SqlBackend (RIO env) ()
storeRepoCache Repo
repo (Repo -> Text
repoSubdir Repo
repo) TreeId
tid
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package

getRepo' ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Repo
  -> RawPackageMetadata
  -> RIO env Package
getRepo' :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo' repo :: Repo
repo@Repo{Text
RepoType
repoUrl :: Repo -> Text
repoCommit :: Repo -> Text
repoType :: Repo -> RepoType
repoSubdir :: Text
repoType :: RepoType
repoCommit :: Text
repoUrl :: Text
repoSubdir :: Repo -> Text
..} RawPackageMetadata
rpm = do
  forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive (Repo -> SimpleRepo
rToSimpleRepo Repo
repo) forall a b. (a -> b) -> a -> b
$ \FilePath
tarball -> do
    Path Abs File
abs' <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
tarball
    forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage
      (Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo Repo
repo RawPackageMetadata
rpm)
      RawArchive
        { raLocation :: ArchiveLocation
raLocation = ResolvedPath File -> ArchiveLocation
ALFilePath forall a b. (a -> b) -> a -> b
$ ResolvedPath
            { resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
tarball
            , resolvedAbsolute :: Path Abs File
resolvedAbsolute = Path Abs File
abs'
            }
        , raHash :: Maybe SHA256
raHash = forall a. Maybe a
Nothing
        , raSize :: Maybe FileSize
raSize = forall a. Maybe a
Nothing
        , raSubdir :: Text
raSubdir = Text
repoSubdir
        }
      RawPackageMetadata
rpm

getRepos ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => AggregateRepo
  -> RIO env [Package]
getRepos :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
AggregateRepo -> RIO env [Package]
getRepos repo :: AggregateRepo
repo@(AggregateRepo (SimpleRepo{Text
RepoType
sRepoUrl :: SimpleRepo -> Text
sRepoCommit :: SimpleRepo -> Text
sRepoType :: SimpleRepo -> RepoType
sRepoType :: RepoType
sRepoCommit :: Text
sRepoUrl :: Text
..}) [(Text, RawPackageMetadata)]
repoSubdirs) = forall {env}.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
(AggregateRepo -> RIO env [(Package, Text)]) -> RIO env [Package]
withCache forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
AggregateRepo -> RIO env [(Package, Text)]
getRepos'
 where
  withCache :: (AggregateRepo -> RIO env [(Package, Text)]) -> RIO env [Package]
withCache AggregateRepo -> RIO env [(Package, Text)]
inner = do
    [Either (Text, RawPackageMetadata) (Package, Text)]
pkgs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, RawPackageMetadata)]
repoSubdirs forall a b. (a -> b) -> a -> b
$ \(Text
subdir, RawPackageMetadata
rpm) -> forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
      forall env. Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just TreeId
tid ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (, Text
subdir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById (Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) RawPackageMetadata
rpm) TreeId
tid
        Maybe TreeId
Nothing  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Text
subdir, RawPackageMetadata
rpm)
    let ([(Text, RawPackageMetadata)]
missingPkgs, [(Package, Text)]
cachedPkgs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Text, RawPackageMetadata) (Package, Text)]
pkgs
    [Package]
newPkgs <-
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, RawPackageMetadata)]
missingPkgs
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else do
        [(Package, Text)]
packages <- AggregateRepo -> RIO env [(Package, Text)]
inner AggregateRepo
repo { aRepoSubdirs :: [(Text, RawPackageMetadata)]
aRepoSubdirs = [(Text, RawPackageMetadata)]
missingPkgs }
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Package, Text)]
packages forall a b. (a -> b) -> a -> b
$ \(Package
package, Text
subdir) -> do
          forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
            Maybe (Entity Tree)
ment <- forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey forall a b. (a -> b) -> a -> b
$ Package -> TreeKey
packageTreeKey Package
package
            case Maybe (Entity Tree)
ment of
              Maybe (Entity Tree)
Nothing -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$
                   FilePath
"invariant violated, Tree not found: "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (Package -> TreeKey
packageTreeKey Package
package)
              Just (Entity TreeId
tid Tree
_) ->
                forall env.
Repo -> Text -> TreeId -> ReaderT SqlBackend (RIO env) ()
storeRepoCache (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) Text
subdir TreeId
tid
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => [a] -> [a]
nubOrd ((forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Package, Text)]
cachedPkgs) forall a. [a] -> [a] -> [a]
++ [Package]
newPkgs))

getRepos' ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => AggregateRepo
  -> RIO env [(Package, Text)] -- ^ [(package, subdir)]

getRepos' :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
AggregateRepo -> RIO env [(Package, Text)]
getRepos' ar :: AggregateRepo
ar@(AggregateRepo (SimpleRepo{Text
RepoType
sRepoType :: RepoType
sRepoCommit :: Text
sRepoUrl :: Text
sRepoUrl :: SimpleRepo -> Text
sRepoCommit :: SimpleRepo -> Text
sRepoType :: SimpleRepo -> RepoType
..}) [(Text, RawPackageMetadata)]
repoSubdirs) = do
  forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive (AggregateRepo -> SimpleRepo
arToSimpleRepo AggregateRepo
ar) forall a b. (a -> b) -> a -> b
$ \FilePath
tarball -> do
    Path Abs File
abs' <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
tarball
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, RawPackageMetadata)]
repoSubdirs forall a b. (a -> b) -> a -> b
$ \(Text
subdir, RawPackageMetadata
rpm) -> do
      (,Text
subdir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage
        (Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) RawPackageMetadata
rpm)
        RawArchive
          { raLocation :: ArchiveLocation
raLocation = ResolvedPath File -> ArchiveLocation
ALFilePath forall a b. (a -> b) -> a -> b
$ ResolvedPath
              { resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
tarball
              , resolvedAbsolute :: Path Abs File
resolvedAbsolute = Path Abs File
abs'
              }
          , raHash :: Maybe SHA256
raHash = forall a. Maybe a
Nothing
          , raSize :: Maybe FileSize
raSize = forall a. Maybe a
Nothing
          , raSubdir :: Text
raSubdir = Text
subdir
          }
        RawPackageMetadata
rpm

-- | Fetch a repository and create a (temporary) tar archive from it. Pass the

-- path of the generated tarball to the given action.

withRepoArchive ::
     forall env a. (HasLogFunc env, HasProcessContext env)
  => SimpleRepo
  -> (FilePath -> RIO env a)
  -> RIO env a
withRepoArchive :: forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive SimpleRepo
sr FilePath -> RIO env a
action =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"with-repo-archive" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpdirArchive -> do
    let tarball :: FilePath
tarball = FilePath
tmpdirArchive FilePath -> FilePath -> FilePath
</> FilePath
"foo.tar"
    forall env.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> FilePath -> RIO env ()
createRepoArchive SimpleRepo
sr FilePath
tarball
    FilePath -> RIO env a
action FilePath
tarball

-- | Run a git command, setting appropriate environment variable settings. See

-- <https://github.com/commercialhaskell/stack/issues/3748>.

runGitCommand ::
     (HasLogFunc env, HasProcessContext env)
  => [String] -- ^ args

  -> RIO env ()
runGitCommand :: forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand [FilePath]
args =
  forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(EnvVars -> EnvVars) -> m a -> m a
withModifyEnvVars forall {a}. Map Text a -> Map Text a
go forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"git" [FilePath]
args forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
 where
  go :: Map Text a -> Map Text a
go = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_DIR"
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_CEILING_DIRECTORIES"
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_WORK_TREE"
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_INDEX_FILE"
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls

     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_ALTERNATE_OBJECT_DIRECTORIES"

-- Include submodules files into the archive: use `git submodule foreach` to

-- execute `git archive` in each submodule and generate tar archive. With bsd

-- tar, the generated archive is extracted to a temporary folder and the files

-- in them are added to the tarball referenced by the variable tarball in the

-- haskell code. This is done in GNU tar with -A option.

archiveSubmodules ::
     (HasLogFunc env, HasProcessContext env)
  => FilePath
  -> RIO env ()
archiveSubmodules :: forall env.
(HasLogFunc env, HasProcessContext env) =>
FilePath -> RIO env ()
archiveSubmodules FilePath
tarball = do
  TarType
tarType <- forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getGitTarType
  let forceLocal :: FilePath
forceLocal =
          if Bool
osIsWindows
          then FilePath
" --force-local "
          else forall a. Monoid a => a
mempty
  case TarType
tarType of
    TarType
Gnu -> forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
      [ FilePath
"submodule"
      , FilePath
"foreach"
      , FilePath
"--recursive"
      , FilePath
"git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; "
        forall a. Semigroup a => a -> a -> a
<> FilePath
"tar" forall a. Semigroup a => a -> a -> a
<> FilePath
forceLocal forall a. Semigroup a => a -> a -> a
<> FilePath
" -Af " forall a. Semigroup a => a -> a -> a
<> FilePath
tarball forall a. Semigroup a => a -> a -> a
<> FilePath
" bar.tar"
      ]
    TarType
Bsd -> forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
      [ FilePath
"submodule"
      , FilePath
"foreach"
      , FilePath
"--recursive"
      , FilePath
"git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; "
        forall a. Semigroup a => a -> a -> a
<> FilePath
"rm -rf temp; mkdir temp; mv bar.tar temp/; "
        forall a. Semigroup a => a -> a -> a
<> FilePath
"tar -C temp -xf temp/bar.tar; "
        forall a. Semigroup a => a -> a -> a
<> FilePath
"rm temp/bar.tar; "
        forall a. Semigroup a => a -> a -> a
<> FilePath
"tar -C temp -rf " forall a. Semigroup a => a -> a -> a
<> FilePath
tarball forall a. Semigroup a => a -> a -> a
<> FilePath
" . ;"
      ]

-- | Run an hg command

runHgCommand ::
     (HasLogFunc env, HasProcessContext env)
  => [String] -- ^ args

  -> RIO env ()
runHgCommand :: forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runHgCommand [FilePath]
args = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"hg" [FilePath]
args forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_

-- | Create a tarball containing files from a repository

createRepoArchive ::
     forall env. (HasLogFunc env, HasProcessContext env)
  => SimpleRepo
  -> FilePath -- ^ Output tar archive filename

  -> RIO env ()
createRepoArchive :: forall env.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> FilePath -> RIO env ()
createRepoArchive SimpleRepo
sr FilePath
tarball = do
  forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> RIO env a -> RIO env a
withRepo SimpleRepo
sr forall a b. (a -> b) -> a -> b
$
    case SimpleRepo -> RepoType
sRepoType SimpleRepo
sr of
      RepoType
RepoGit -> do
        forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
          [FilePath
"-c", FilePath
"core.autocrlf=false", FilePath
"archive", FilePath
"-o", FilePath
tarball, FilePath
"HEAD"]
        forall env.
(HasLogFunc env, HasProcessContext env) =>
FilePath -> RIO env ()
archiveSubmodules FilePath
tarball
      RepoType
RepoHg -> forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runHgCommand [FilePath
"archive", FilePath
tarball, FilePath
"-X", FilePath
".hg_archival.txt"]


-- | Clone the repository (and, in the case of Git and if necessary, fetch the

-- specific commit) and execute the action with the working directory set to the

-- repository root.

--

-- @since 0.1.0.0

withRepo ::
     forall env a. (HasLogFunc env, HasProcessContext env)
  => SimpleRepo
  -> RIO env a
  -> RIO env a
withRepo :: forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> RIO env a -> RIO env a
withRepo sr :: SimpleRepo
sr@SimpleRepo{Text
RepoType
sRepoType :: RepoType
sRepoCommit :: Text
sRepoUrl :: Text
sRepoUrl :: SimpleRepo -> Text
sRepoCommit :: SimpleRepo -> Text
sRepoType :: SimpleRepo -> RepoType
..} RIO env a
action =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"with-repo" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
    let repoUrl :: FilePath
repoUrl = Text -> FilePath
T.unpack Text
sRepoUrl
        repoCommit :: FilePath
repoCommit = Text -> FilePath
T.unpack Text
sRepoCommit
        dir :: FilePath
dir = FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
"cloned"
        ([FilePath] -> RIO env ()
runCommand, [FilePath]
resetArgs) =
          case RepoType
sRepoType of
            RepoType
RepoGit ->
              ( forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
              , [FilePath
"reset", FilePath
"--hard", FilePath
repoCommit]
              )
            RepoType
RepoHg ->
              ( forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runHgCommand
              , [FilePath
"update", FilePath
"-C", FilePath
repoCommit]
              )
        fetchCommit :: [FilePath]
fetchCommit = [FilePath
"fetch", FilePath
repoUrl, FilePath
repoCommit]
        submoduleArgs :: [FilePath]
submoduleArgs = [FilePath
"submodule", FilePath
"update", FilePath
"--init", FilePath
"--recursive"]
        fixANSIForWindows :: RIO env ()
fixANSIForWindows =
          -- On Windows 10, an upstream issue with the `git clone` command means

          -- that command clears, but does not then restore, the

          -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The

          -- following hack re-enables the lost ANSI-capability.

          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
stdout
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Cloning " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sRepoCommit forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sRepoUrl
    [FilePath] -> RIO env ()
runCommand [FilePath
"clone", FilePath
repoUrl, FilePath
dir]
    RIO env ()
fixANSIForWindows
    Bool
created <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
dir
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
created forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ SimpleRepo -> PantryException
FailedToCloneRepo SimpleRepo
sr

    -- Note we do not immediately change directories into the new temporary

    -- directory, but instead wait until we have finished cloning the repo. This

    -- is because the repo URL may be a relative path on the local filesystem,

    -- and we should interpret it as relative to the current directory, not the

    -- temporary directory.

    forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir FilePath
dir forall a b. (a -> b) -> a -> b
$ do
      case RepoType
sRepoType of
        RepoType
RepoGit -> do
          forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
            -- This will result in a failure exit code if the specified commit

            -- is not in the clone of the repository.

            ([FilePath] -> RIO env ()
runCommand [FilePath]
resetArgs)
            ( \(ExitCodeException
_ :: ExitCodeException) -> do
               -- Perhaps the specified commit is not one that is brought across

               -- by `git clone`. For example, in the case of a GitHub

               -- repository, it may be a commit from a different repository

               -- that is the subject of an unmerged pull request. Try to fetch

               -- the specific commit and then try again.

               [FilePath] -> RIO env ()
runCommand [FilePath]
fetchCommit
               [FilePath] -> RIO env ()
runCommand [FilePath]
resetArgs
            )
          [FilePath] -> RIO env ()
runCommand [FilePath]
submoduleArgs
          RIO env ()
fixANSIForWindows
        RepoType
RepoHg -> [FilePath] -> RIO env ()
runCommand [FilePath]
resetArgs
      RIO env a
action