{-# 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 = do
(stdoutBS, _) <- proc "tar" ["--version"] readProcess_
let bs = toStrict stdoutBS
if "GNU" `isInfixOf` bs
then pure Gnu
else if "bsdtar" `isInfixOf` bs
then pure Bsd
else do
logError $ "Either GNU Tar or BSD tar is required on the PATH."
throwString "Proper tar executable not found in the environment"
fetchReposRaw
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(Repo, RawPackageMetadata)]
-> RIO env ()
fetchReposRaw pairs = for_ pairs $ uncurry getRepo
fetchRepos
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(Repo, PackageMetadata)]
-> RIO env ()
fetchRepos pairs = do
fetchReposRaw $ map (second toRawPM) pairs
getRepoKey
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Repo
-> RawPackageMetadata
-> RIO env TreeKey
getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm
getRepo
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Repo
-> RawPackageMetadata
-> RIO env Package
getRepo repo pm =
withCache $ getRepo' repo pm
where
withCache
:: RIO env Package
-> RIO env Package
withCache inner = do
mtid <- withStorage (loadRepoCache repo (repoSubdir repo))
case mtid of
Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid
Nothing -> do
package <- inner
withStorage $ do
ment <- getTreeForKey $ packageTreeKey package
case ment of
Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package)
Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid
pure package
getRepo'
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Repo
-> RawPackageMetadata
-> RIO env Package
getRepo' repo rpm = do
withRepoArchive repo $ \tarball -> do
abs' <- resolveFile' tarball
getArchivePackage
(RPLIRepo repo rpm)
RawArchive
{ raLocation = ALFilePath $ ResolvedPath
{ resolvedRelative = RelFilePath $ T.pack tarball
, resolvedAbsolute = abs'
}
, raHash = Nothing
, raSize = Nothing
, raSubdir = repoSubdir repo
}
rpm
withRepoArchive
:: forall env a. (HasLogFunc env, HasProcessContext env)
=> Repo
-> (FilePath -> RIO env a)
-> RIO env a
withRepoArchive repo action =
withSystemTempDirectory "with-repo-archive" $ \tmpdir -> do
let tarball = tmpdir </> "foo.tar"
createRepoArchive repo tarball
action tarball
runGitCommand
:: (HasLogFunc env, HasProcessContext env)
=> [String]
-> RIO env ()
runGitCommand args =
withModifyEnvVars go $
void $ proc "git" args readProcess_
where
go = Map.delete "GIT_DIR"
. Map.delete "GIT_CEILING_DIRECTORIES"
. Map.delete "GIT_WORK_TREE"
. Map.delete "GIT_INDEX_FILE"
. Map.delete "GIT_OBJECT_DIRECTORY"
. Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES"
archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env ()
archiveSubmodules tarball = do
tarType <- getTarType
let forceLocal =
if osIsWindows
then " --force-local "
else mempty
case tarType of
Gnu -> runGitCommand
[ "submodule", "foreach", "--recursive"
, "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; "
<> "tar" <> forceLocal <> " -Af " <> tarball <> " bar.tar"
]
Bsd ->
runGitCommand
[ "submodule"
, "foreach"
, "--recursive"
, "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD;" <>
" rm -rf temp; mkdir temp; mv bar.tar temp/; tar " <>
" -C temp -xf temp/bar.tar; " <>
"rm temp/bar.tar; tar " <>
" -C temp -rf " <>
tarball <>
" . ;"
]
runHgCommand
:: (HasLogFunc env, HasProcessContext env)
=> [String]
-> RIO env ()
runHgCommand args = void $ proc "hg" args readProcess_
createRepoArchive ::
forall env. (HasLogFunc env, HasProcessContext env)
=> Repo
-> FilePath
-> RIO env ()
createRepoArchive repo tarball = do
withRepo repo $
case repoType repo of
RepoGit -> do
runGitCommand
["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"]
archiveSubmodules tarball
RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"]
withRepo
:: forall env a. (HasLogFunc env, HasProcessContext env)
=> Repo
-> RIO env a
-> RIO env a
withRepo repo@(Repo url commit repoType' _subdir) action =
withSystemTempDirectory "with-repo" $ \tmpDir -> do
let dir = tmpDir </> "cloned"
(runCommand, resetArgs, submoduleArgs) =
case repoType' of
RepoGit ->
( runGitCommand
, ["reset", "--hard", T.unpack commit]
, Just ["submodule", "update", "--init", "--recursive"]
)
RepoHg ->
( runHgCommand
, ["update", "-C", T.unpack commit]
, Nothing
)
fixANSIForWindows =
when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout
logInfo $ "Cloning " <> display commit <> " from " <> display url
runCommand ["clone", T.unpack url, dir]
fixANSIForWindows
created <- doesDirectoryExist dir
unless created $ throwIO $ FailedToCloneRepo repo
withWorkingDir dir $ do
runCommand resetArgs
traverse_ runCommand submoduleArgs
fixANSIForWindows
action