{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module Pantry.Repo
  ( fetchReposRaw
  , fetchRepos
  , getRepo
  , getRepoKey
  , createRepoArchive
  , withRepoArchive
  , withRepo
  ) where


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

data TarType = Gnu | Bsd

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
repoType :: Repo -> RepoType
repoCommit :: Repo -> Text
repoUrl :: Repo -> Text
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
sRepoType :: SimpleRepo -> RepoType
sRepoCommit :: SimpleRepo -> Text
sRepoUrl :: SimpleRepo -> Text
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
sRepoType :: SimpleRepo -> RepoType
sRepoCommit :: SimpleRepo -> Text
sRepoUrl :: SimpleRepo -> Text
..}) [(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
getTarType
  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/; tar " forall a. Semigroup a => a -> a -> a
<>
            FilePath
" -C temp -xf temp/bar.tar; " forall a. Semigroup a => a -> a -> a
<>
            FilePath
"rm temp/bar.tar; tar " forall a. Semigroup a => a -> a -> a
<>
            FilePath
" -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 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
sRepoType :: SimpleRepo -> RepoType
sRepoCommit :: SimpleRepo -> Text
sRepoUrl :: SimpleRepo -> Text
..} 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
    -- 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.

    let dir :: FilePath
dir = FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
"cloned"
        ([FilePath] -> RIO env ()
runCommand, [FilePath]
resetArgs, Maybe [FilePath]
submoduleArgs) =
          case RepoType
sRepoType of
            RepoType
RepoGit ->
              ( forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
              , [FilePath
"reset", FilePath
"--hard", Text -> FilePath
T.unpack Text
sRepoCommit]
              , forall a. a -> Maybe a
Just [FilePath
"submodule", FilePath
"update", FilePath
"--init", FilePath
"--recursive"]
              )
            RepoType
RepoHg ->
              ( forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runHgCommand
              , [FilePath
"update", FilePath
"-C", Text -> FilePath
T.unpack Text
sRepoCommit]
              , forall a. Maybe a
Nothing
              )
        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", Text -> FilePath
T.unpack Text
sRepoUrl, 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

    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
      [FilePath] -> RIO env ()
runCommand [FilePath]
resetArgs
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ [FilePath] -> RIO env ()
runCommand Maybe [FilePath]
submoduleArgs
      RIO env ()
fixANSIForWindows
      RIO env a
action