{-# 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
  (ExitCode
_, ByteString
stdoutBS, ByteString
_) <- FilePath
-> [FilePath]
-> (ProcessConfig () () ()
    -> RIO env (ExitCode, ByteString, ByteString))
-> RIO env (ExitCode, 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 (ExitCode, ByteString, ByteString)
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
  TarType -> RIO env TarType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TarType -> RIO env TarType) -> TarType -> RIO env TarType
forall a b. (a -> b) -> a -> b
$ if ByteString
"GNU" ByteString -> ByteString -> Bool
`isInfixOf` ByteString
bs then TarType
Gnu else TarType
Bsd

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
  -- TODO be more efficient, group together shared archives
  [(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 -- potential optimization

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

-- | 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)
  => 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

-- | 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 :: [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" -- possible optimization: set this to something Pantry controls
       (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"

-- 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 :: 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
" . ;"
          ]

-- | Run an hg command
runHgCommand
  :: (HasLogFunc env, HasProcessContext env)
  => [String] -- ^ args
  -> 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_

-- | Create a tarball containing files from a repository
createRepoArchive ::
     forall env. (HasLogFunc env, HasProcessContext env)
  => Repo
  -> FilePath -- ^ Output tar archive filename
  -> 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"]


-- | 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)
  => 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
    -- 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
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 =
          -- 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
          -- folowing hack re-enables the lost ANSI-capability.
          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