{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 :: RIO env TarType
getTarType = do
(ByteString
stdoutBS, ByteString
_) <- FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, 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"] ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
let bs :: ByteString
bs = ByteString -> ByteString
toStrict ByteString
stdoutBS
if ByteString
"GNU" ByteString -> ByteString -> Bool
`isInfixOf` ByteString
bs
then TarType -> RIO env TarType
forall (f :: * -> *) a. Applicative f => a -> f a
pure TarType
Gnu
else if ByteString
"bsdtar" ByteString -> ByteString -> Bool
`isInfixOf` ByteString
bs
then TarType -> RIO env TarType
forall (f :: * -> *) a. Applicative f => a -> f a
pure TarType
Bsd
else do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Either GNU Tar or BSD tar is required on the PATH."
FilePath -> RIO env TarType
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Proper tar executable not found in the environment"
fetchReposRaw
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(Repo, RawPackageMetadata)]
-> RIO env ()
fetchReposRaw :: [(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw [(Repo, RawPackageMetadata)]
pairs = [(Repo, RawPackageMetadata)]
-> ((Repo, RawPackageMetadata) -> RIO env Package) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Repo, RawPackageMetadata)]
pairs (((Repo, RawPackageMetadata) -> RIO env Package) -> RIO env ())
-> ((Repo, RawPackageMetadata) -> RIO env Package) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ (Repo -> RawPackageMetadata -> RIO env Package)
-> (Repo, RawPackageMetadata) -> RIO env Package
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Repo -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo
fetchRepos
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(Repo, PackageMetadata)]
-> RIO env ()
fetchRepos :: [(Repo, PackageMetadata)] -> RIO env ()
fetchRepos [(Repo, PackageMetadata)]
pairs = do
[(Repo, RawPackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, RawPackageMetadata)] -> RIO env ()
fetchReposRaw ([(Repo, RawPackageMetadata)] -> RIO env ())
-> [(Repo, RawPackageMetadata)] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ((Repo, PackageMetadata) -> (Repo, RawPackageMetadata))
-> [(Repo, PackageMetadata)] -> [(Repo, RawPackageMetadata)]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageMetadata -> RawPackageMetadata)
-> (Repo, PackageMetadata) -> (Repo, RawPackageMetadata)
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 :: Repo -> RawPackageMetadata -> RIO env TreeKey
getRepoKey Repo
repo RawPackageMetadata
rpm = Package -> TreeKey
packageTreeKey (Package -> TreeKey) -> RIO env Package -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repo -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
rpm
getRepo
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Repo
-> RawPackageMetadata
-> RIO env Package
getRepo :: Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
pm =
RIO env Package -> RIO env Package
withCache (RIO env Package -> RIO env Package)
-> RIO env Package -> RIO env Package
forall a b. (a -> b) -> a -> b
$ Repo -> RawPackageMetadata -> RIO env Package
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 <- ReaderT SqlBackend (RIO env) (Maybe TreeId)
-> RIO env (Maybe TreeId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (Repo -> Text -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
forall env.
Repo -> Text -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache Repo
repo (Repo -> Text
repoSubdir Repo
repo))
case Maybe TreeId
mtid of
Just TreeId
tid -> ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) Package -> RIO env Package)
-> ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
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
ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (Entity Tree)
ment <- TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall a b. (a -> b) -> a -> b
$ Package -> TreeKey
packageTreeKey Package
package
case Maybe (Entity Tree)
ment of
Maybe (Entity Tree)
Nothing -> FilePath -> ReaderT SqlBackend (RIO env) ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> ReaderT SqlBackend (RIO env) ())
-> FilePath -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ FilePath
"invariant violated, Tree not found: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TreeKey -> FilePath
forall a. Show a => a -> FilePath
show (Package -> TreeKey
packageTreeKey Package
package)
Just (Entity TreeId
tid Tree
_) -> Repo -> Text -> TreeId -> ReaderT SqlBackend (RIO env) ()
forall env.
Repo -> Text -> TreeId -> ReaderT SqlBackend (RIO env) ()
storeRepoCache Repo
repo (Repo -> Text
repoSubdir Repo
repo) TreeId
tid
Package -> RIO env Package
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' :: Repo -> RawPackageMetadata -> RIO env Package
getRepo' Repo
repo RawPackageMetadata
rpm = do
Repo -> (FilePath -> RIO env Package) -> RIO env Package
forall env a.
(HasLogFunc env, HasProcessContext env) =>
Repo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive Repo
repo ((FilePath -> RIO env Package) -> RIO env Package)
-> (FilePath -> RIO env Package) -> RIO env Package
forall a b. (a -> b) -> a -> b
$ \FilePath
tarball -> do
Path Abs File
abs' <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
tarball
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
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 :: ArchiveLocation
-> Maybe SHA256 -> Maybe FileSize -> Text -> RawArchive
RawArchive
{ raLocation :: ArchiveLocation
raLocation = ResolvedPath File -> ArchiveLocation
ALFilePath (ResolvedPath File -> ArchiveLocation)
-> ResolvedPath File -> ArchiveLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath :: forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath
{ resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath (Text -> RelFilePath) -> Text -> 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 = Maybe SHA256
forall a. Maybe a
Nothing
, raSize :: Maybe FileSize
raSize = Maybe FileSize
forall a. Maybe a
Nothing
, raSubdir :: Text
raSubdir = Repo -> Text
repoSubdir Repo
repo
}
RawPackageMetadata
rpm
withRepoArchive
:: forall env a. (HasLogFunc env, HasProcessContext env)
=> Repo
-> (FilePath -> RIO env a)
-> RIO env a
withRepoArchive :: Repo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive Repo
repo FilePath -> RIO env a
action =
FilePath -> (FilePath -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"with-repo-archive" ((FilePath -> RIO env a) -> RIO env a)
-> (FilePath -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpdir -> do
let tarball :: FilePath
tarball = FilePath
tmpdir FilePath -> FilePath -> FilePath
</> FilePath
"foo.tar"
Repo -> FilePath -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
Repo -> FilePath -> RIO env ()
createRepoArchive Repo
repo FilePath
tarball
FilePath -> RIO env a
action FilePath
tarball
runGitCommand
:: (HasLogFunc env, HasProcessContext env)
=> [String]
-> RIO env ()
runGitCommand :: [FilePath] -> RIO env ()
runGitCommand [FilePath]
args =
(EnvVars -> EnvVars) -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(EnvVars -> EnvVars) -> m a -> m a
withModifyEnvVars EnvVars -> EnvVars
forall a. Map Text a -> Map Text a
go (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
RIO env (ByteString, ByteString) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (ByteString, ByteString) -> RIO env ())
-> RIO env (ByteString, ByteString) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, 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]
args ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
where
go :: Map Text a -> Map Text a
go = Text -> Map Text a -> Map Text a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_DIR"
(Map Text a -> Map Text a)
-> (Map Text a -> Map Text a) -> Map Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text a -> Map Text a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_CEILING_DIRECTORIES"
(Map Text a -> Map Text a)
-> (Map Text a -> Map Text a) -> Map Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text a -> Map Text a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_WORK_TREE"
(Map Text a -> Map Text a)
-> (Map Text a -> Map Text a) -> Map Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text a -> Map Text a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_INDEX_FILE"
(Map Text a -> Map Text a)
-> (Map Text a -> Map Text a) -> Map Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text a -> Map Text a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_OBJECT_DIRECTORY"
(Map Text a -> Map Text a)
-> (Map Text a -> Map Text a) -> Map Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Map Text a -> Map Text a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"GIT_ALTERNATE_OBJECT_DIRECTORIES"
archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env ()
archiveSubmodules :: FilePath -> RIO env ()
archiveSubmodules FilePath
tarball = do
TarType
tarType <- RIO env TarType
forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getTarType
let forceLocal :: FilePath
forceLocal =
if Bool
osIsWindows
then FilePath
" --force-local "
else FilePath
forall a. Monoid a => a
mempty
case TarType
tarType of
TarType
Gnu -> [FilePath] -> RIO env ()
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; "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"tar" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
forceLocal FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -Af " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
tarball FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" bar.tar"
]
TarType
Bsd ->
[FilePath] -> RIO env ()
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;" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
" rm -rf temp; mkdir temp; mv bar.tar temp/; tar " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
" -C temp -xf temp/bar.tar; " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
"rm temp/bar.tar; tar " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
" -C temp -rf " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
tarball FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
" . ;"
]
runHgCommand
:: (HasLogFunc env, HasProcessContext env)
=> [String]
-> RIO env ()
runHgCommand :: [FilePath] -> RIO env ()
runHgCommand [FilePath]
args = RIO env (ByteString, ByteString) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (ByteString, ByteString) -> RIO env ())
-> RIO env (ByteString, ByteString) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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 ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
createRepoArchive ::
forall env. (HasLogFunc env, HasProcessContext env)
=> Repo
-> FilePath
-> RIO env ()
createRepoArchive :: Repo -> FilePath -> RIO env ()
createRepoArchive Repo
repo FilePath
tarball = do
Repo -> RIO env () -> RIO env ()
forall env a.
(HasLogFunc env, HasProcessContext env) =>
Repo -> RIO env a -> RIO env a
withRepo Repo
repo (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
case Repo -> RepoType
repoType Repo
repo of
RepoType
RepoGit -> do
[FilePath] -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
[FilePath
"-c", FilePath
"core.autocrlf=false", FilePath
"archive", FilePath
"-o", FilePath
tarball, FilePath
"HEAD"]
FilePath -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
FilePath -> RIO env ()
archiveSubmodules FilePath
tarball
RepoType
RepoHg -> [FilePath] -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runHgCommand [FilePath
"archive", FilePath
tarball, FilePath
"-X", FilePath
".hg_archival.txt"]
withRepo
:: forall env a. (HasLogFunc env, HasProcessContext env)
=> Repo
-> RIO env a
-> RIO env a
withRepo :: Repo -> RIO env a -> RIO env a
withRepo repo :: Repo
repo@(Repo Text
url Text
commit RepoType
repoType' Text
_subdir) RIO env a
action =
FilePath -> (FilePath -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"with-repo" ((FilePath -> RIO env a) -> RIO env a)
-> (FilePath -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
let dir :: FilePath
dir = FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
"cloned"
([FilePath] -> RIO env ()
runCommand, [FilePath]
resetArgs, Maybe [FilePath]
submoduleArgs) =
case RepoType
repoType' of
RepoType
RepoGit ->
( [FilePath] -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
, [FilePath
"reset", FilePath
"--hard", Text -> FilePath
T.unpack Text
commit]
, [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just [FilePath
"submodule", FilePath
"update", FilePath
"--init", FilePath
"--recursive"]
)
RepoType
RepoHg ->
( [FilePath] -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runHgCommand
, [FilePath
"update", FilePath
"-C", Text -> FilePath
T.unpack Text
commit]
, Maybe [FilePath]
forall a. Maybe a
Nothing
)
fixANSIForWindows :: RIO env ()
fixANSIForWindows =
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RIO env (Maybe Bool) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (Maybe Bool) -> RIO env ())
-> RIO env (Maybe Bool) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe Bool) -> RIO env (Maybe Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> RIO env (Maybe Bool))
-> IO (Maybe Bool) -> RIO env (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
stdout
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Cloning " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
commit Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url
[FilePath] -> RIO env ()
runCommand [FilePath
"clone", Text -> FilePath
T.unpack Text
url, FilePath
dir]
RIO env ()
fixANSIForWindows
Bool
created <- FilePath -> RIO env Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
dir
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
created (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Repo -> PantryException
FailedToCloneRepo Repo
repo
FilePath -> RIO env a -> RIO env a
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir FilePath
dir (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ do
[FilePath] -> RIO env ()
runCommand [FilePath]
resetArgs
([FilePath] -> RIO env ()) -> Maybe [FilePath] -> RIO env ()
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