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

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

import           Database.Persist.Class.PersistEntity ( Entity (..) )
import           Pantry.Archive ( getArchivePackage )
import           Pantry.Storage
                   ( getTreeForKey, loadPackageById, loadRepoCache
                   , storeRepoCache, withStorage
                   )
import           Pantry.Types
                   ( AggregateRepo (..), ArchiveLocation (..), HasPantryConfig
                   , Package (..), PackageMetadata (..), PantryException (..)
                   , RawArchive (..), RawPackageLocationImmutable (..)
                   , RawPackageMetadata (..), RelFilePath (..), Repo (..)
                   , RepoType (..), ResolvedPath (..), SimpleRepo (..)
                   , TreeKey (..), arToSimpleRepo, rToSimpleRepo
                   , toAggregateRepos, toRawPM
                   )
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
                   ( ExitCodeException (..), HasProcessContext, proc
                   , readProcess, readProcess_, withModifyEnvVars
                   , withWorkingDir
                   )
import qualified RIO.Text as T
#if MIN_VERSION_ansi_terminal(1, 0, 2)
import           System.Console.ANSI ( hNowSupportsANSI )
#else
import           System.Console.ANSI ( hSupportsANSIWithoutEmulation )
#endif
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
_) <- 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
"git" [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
    -- 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 TarType -> RIO env TarType
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TarType
Gnu else RIO env TarType
forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getTarType
  else RIO env TarType
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
_) <- 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 a. a -> RIO env a
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

-- | 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
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug ([AggregateRepo] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [AggregateRepo]
repos)
  [AggregateRepo]
-> (AggregateRepo -> RIO env [Package]) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [AggregateRepo]
repos AggregateRepo -> RIO env [Package]
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

  [(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 b c a. (b -> c) -> (a, b) -> (a, c)
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 (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 :: 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 (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 -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
forall env. Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache 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 a. a -> RIO env a
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
repoSubdir :: Repo -> Text
repoUrl :: Text
repoCommit :: Text
repoType :: RepoType
repoSubdir :: Text
repoUrl :: Repo -> Text
repoCommit :: Repo -> Text
repoType :: Repo -> RepoType
..} RawPackageMetadata
rpm = do
  SimpleRepo -> (FilePath -> RIO env Package) -> RIO env Package
forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive (Repo -> SimpleRepo
rToSimpleRepo 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
        { raLocation :: ArchiveLocation
raLocation = ResolvedPath File -> ArchiveLocation
ALFilePath (ResolvedPath File -> ArchiveLocation)
-> ResolvedPath File -> ArchiveLocation
forall a b. (a -> b) -> a -> b
$ 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 = 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 :: Text
sRepoCommit :: Text
sRepoType :: RepoType
sRepoUrl :: SimpleRepo -> Text
sRepoCommit :: SimpleRepo -> Text
sRepoType :: SimpleRepo -> RepoType
..}) [(Text, RawPackageMetadata)]
repoSubdirs) = (AggregateRepo -> RIO env [(Package, Text)]) -> RIO env [Package]
forall {env}.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
(AggregateRepo -> RIO env [(Package, Text)]) -> RIO env [Package]
withCache AggregateRepo -> RIO env [(Package, Text)]
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 <- [(Text, RawPackageMetadata)]
-> ((Text, RawPackageMetadata)
    -> RIO env (Either (Text, RawPackageMetadata) (Package, Text)))
-> RIO env [Either (Text, RawPackageMetadata) (Package, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, RawPackageMetadata)]
repoSubdirs (((Text, RawPackageMetadata)
  -> RIO env (Either (Text, RawPackageMetadata) (Package, Text)))
 -> RIO env [Either (Text, RawPackageMetadata) (Package, Text)])
-> ((Text, RawPackageMetadata)
    -> RIO env (Either (Text, RawPackageMetadata) (Package, Text)))
-> RIO env [Either (Text, RawPackageMetadata) (Package, Text)]
forall a b. (a -> b) -> a -> b
$ \(Text
subdir, RawPackageMetadata
rpm) -> ReaderT
  SqlBackend
  (RIO env)
  (Either (Text, RawPackageMetadata) (Package, Text))
-> RIO env (Either (Text, RawPackageMetadata) (Package, Text))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT
   SqlBackend
   (RIO env)
   (Either (Text, RawPackageMetadata) (Package, Text))
 -> RIO env (Either (Text, RawPackageMetadata) (Package, Text)))
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Text, RawPackageMetadata) (Package, Text))
-> RIO env (Either (Text, RawPackageMetadata) (Package, Text))
forall a b. (a -> b) -> a -> b
$ do
      Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
forall env. Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) ReaderT SqlBackend (RIO env) (Maybe TreeId)
-> (Maybe TreeId
    -> ReaderT
         SqlBackend
         (RIO env)
         (Either (Text, RawPackageMetadata) (Package, Text)))
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Text, RawPackageMetadata) (Package, Text))
forall a b.
ReaderT SqlBackend (RIO env) a
-> (a -> ReaderT SqlBackend (RIO env) b)
-> ReaderT SqlBackend (RIO env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just TreeId
tid ->
          ((Package, Text)
 -> Either (Text, RawPackageMetadata) (Package, Text))
-> ReaderT SqlBackend (RIO env) (Package, Text)
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Text, RawPackageMetadata) (Package, Text))
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Package, Text)
-> Either (Text, RawPackageMetadata) (Package, Text)
forall a b. b -> Either a b
Right (ReaderT SqlBackend (RIO env) (Package, Text)
 -> ReaderT
      SqlBackend
      (RIO env)
      (Either (Text, RawPackageMetadata) (Package, Text)))
-> ReaderT SqlBackend (RIO env) (Package, Text)
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Text, RawPackageMetadata) (Package, Text))
forall a b. (a -> b) -> a -> b
$ (, Text
subdir) (Package -> (Package, Text))
-> ReaderT SqlBackend (RIO env) Package
-> ReaderT SqlBackend (RIO env) (Package, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) RawPackageMetadata
rpm) TreeId
tid
        Maybe TreeId
Nothing  -> Either (Text, RawPackageMetadata) (Package, Text)
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Text, RawPackageMetadata) (Package, Text))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Text, RawPackageMetadata) (Package, Text)
 -> ReaderT
      SqlBackend
      (RIO env)
      (Either (Text, RawPackageMetadata) (Package, Text)))
-> Either (Text, RawPackageMetadata) (Package, Text)
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Text, RawPackageMetadata) (Package, Text))
forall a b. (a -> b) -> a -> b
$ (Text, RawPackageMetadata)
-> Either (Text, RawPackageMetadata) (Package, Text)
forall a b. a -> Either a b
Left (Text
subdir, RawPackageMetadata
rpm)
    let ([(Text, RawPackageMetadata)]
missingPkgs, [(Package, Text)]
cachedPkgs) = [Either (Text, RawPackageMetadata) (Package, Text)]
-> ([(Text, RawPackageMetadata)], [(Package, Text)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Text, RawPackageMetadata) (Package, Text)]
pkgs
    [Package]
newPkgs <-
      if [(Text, RawPackageMetadata)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, RawPackageMetadata)]
missingPkgs
      then [Package] -> RIO env [Package]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else do
        [(Package, Text)]
packages <- AggregateRepo -> RIO env [(Package, Text)]
inner AggregateRepo
repo { aRepoSubdirs = missingPkgs }
        [(Package, Text)]
-> ((Package, Text) -> RIO env Package) -> RIO env [Package]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Package, Text)]
packages (((Package, Text) -> RIO env Package) -> RIO env [Package])
-> ((Package, Text) -> RIO env Package) -> RIO env [Package]
forall a b. (a -> b) -> a -> b
$ \(Package
package, Text
subdir) -> do
          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 (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) Text
subdir TreeId
tid
          Package -> RIO env Package
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
    [Package] -> RIO env [Package]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Package] -> [Package]
forall a. Ord a => [a] -> [a]
nubOrd (((Package, Text) -> Package
forall a b. (a, b) -> a
fst ((Package, Text) -> Package) -> [(Package, Text)] -> [Package]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Package, Text)]
cachedPkgs) [Package] -> [Package] -> [Package]
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
sRepoUrl :: SimpleRepo -> Text
sRepoCommit :: SimpleRepo -> Text
sRepoType :: SimpleRepo -> RepoType
sRepoUrl :: Text
sRepoCommit :: Text
sRepoType :: RepoType
..}) [(Text, RawPackageMetadata)]
repoSubdirs) = do
  SimpleRepo
-> (FilePath -> RIO env [(Package, Text)])
-> RIO env [(Package, Text)]
forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> (FilePath -> RIO env a) -> RIO env a
withRepoArchive (AggregateRepo -> SimpleRepo
arToSimpleRepo AggregateRepo
ar) ((FilePath -> RIO env [(Package, Text)])
 -> RIO env [(Package, Text)])
-> (FilePath -> RIO env [(Package, Text)])
-> RIO env [(Package, Text)]
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
    [(Text, RawPackageMetadata)]
-> ((Text, RawPackageMetadata) -> RIO env (Package, Text))
-> RIO env [(Package, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, RawPackageMetadata)]
repoSubdirs (((Text, RawPackageMetadata) -> RIO env (Package, Text))
 -> RIO env [(Package, Text)])
-> ((Text, RawPackageMetadata) -> RIO env (Package, Text))
-> RIO env [(Package, Text)]
forall a b. (a -> b) -> a -> b
$ \(Text
subdir, RawPackageMetadata
rpm) -> do
      (,Text
subdir) (Package -> (Package, Text))
-> RIO env Package -> RIO env (Package, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (Text -> Text -> RepoType -> Text -> Repo
Repo Text
sRepoUrl Text
sRepoCommit RepoType
sRepoType Text
subdir) RawPackageMetadata
rpm)
        RawArchive
          { raLocation :: ArchiveLocation
raLocation = ResolvedPath File -> ArchiveLocation
ALFilePath (ResolvedPath File -> ArchiveLocation)
-> ResolvedPath File -> ArchiveLocation
forall a b. (a -> b) -> a -> b
$ 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 = 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 =
  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
tmpdirArchive -> do
    let tarball :: FilePath
tarball = FilePath
tmpdirArchive FilePath -> FilePath -> FilePath
</> FilePath
"foo.tar"
    SimpleRepo -> FilePath -> RIO env ()
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 =
  (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 :: forall env.
(HasLogFunc env, HasProcessContext env) =>
FilePath -> RIO env ()
archiveSubmodules FilePath
tarball = do
  TarType
tarType <- RIO env TarType
forall env.
(HasProcessContext env, HasLogFunc env) =>
RIO env TarType
getGitTarType
  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 -> do
      -- Single quotation marks are required around tarball because otherwise,

      -- in the foreach environment, the \ character in absolute paths on

      -- Windows will be interpreted as escaping the following character.

      let foreachCommand :: FilePath
foreachCommand =
            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"
      [FilePath] -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
        [ FilePath
"submodule"
        , FilePath
"foreach"
        , FilePath
"--recursive"
        , FilePath
foreachCommand
        ]
    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/; "
        FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"tar -C temp -xf temp/bar.tar; "
        FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"rm temp/bar.tar; "
        FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"tar -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 :: forall env.
(HasLogFunc env, HasProcessContext env) =>
[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)
  => 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
  SimpleRepo -> RIO env () -> RIO env ()
forall env a.
(HasLogFunc env, HasProcessContext env) =>
SimpleRepo -> RIO env a -> RIO env a
withRepo SimpleRepo
sr (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    case SimpleRepo -> RepoType
sRepoType SimpleRepo
sr 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, 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
sRepoUrl :: SimpleRepo -> Text
sRepoCommit :: SimpleRepo -> Text
sRepoType :: SimpleRepo -> RepoType
sRepoUrl :: Text
sRepoCommit :: Text
sRepoType :: RepoType
..} 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 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 ->
              ( [FilePath] -> RIO env ()
forall env.
(HasLogFunc env, HasProcessContext env) =>
[FilePath] -> RIO env ()
runGitCommand
              , [FilePath
"reset", FilePath
"--hard", FilePath
repoCommit]
              )
            RepoType
RepoHg ->
              ( [FilePath] -> RIO env ()
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.

          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 Bool -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env Bool -> RIO env ()) -> RIO env Bool -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ansi_terminal(1, 0, 2)
            Handle -> IO Bool
hNowSupportsANSI Handle
stdout
#else
            hSupportsANSIWithoutEmulation stdout
#endif
    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
sRepoCommit 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
sRepoUrl
    [FilePath] -> RIO env ()
runCommand [FilePath
"clone", FilePath
repoUrl, 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
$ 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.

    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
      case RepoType
sRepoType of
        RepoType
RepoGit -> do
          RIO env () -> (ExitCodeException -> RIO env ()) -> RIO env ()
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