Talk directly with remote git repo instead of keeping a bare repo locally.

This commit is contained in:
Robin Heggelund Hansen 2022-08-05 10:53:16 +02:00
parent b8cad6791f
commit c9c75c2d13
8 changed files with 66 additions and 118 deletions

View File

@ -15,19 +15,9 @@ import System.Directory qualified as Dir
-- GET VERSIONS
getVersions :: Dirs.PackageCache -> Pkg.Name -> IO (Either Git.Error (V.Version, [V.Version]))
getVersions cache name = do
let repoPath = Dirs.basePackage cache name
repoExists <- Dir.doesDirectoryExist repoPath
retVal <-
if repoExists
then Git.update name repoPath
else Git.clone (Git.githubUrl name) repoPath
case retVal of
Left problem ->
return $ Left problem
Right () ->
Git.tags repoPath
getVersions :: Pkg.Name -> IO (Either Git.Error (V.Version, [V.Version]))
getVersions name =
Git.tags (Git.githubUrl name)
-- GET POSSIBILITIES
@ -36,8 +26,8 @@ bumpPossibilities (latest, previous) =
let allVersions = reverse (latest : previous)
minorPoints = map last (List.groupBy sameMajor allVersions)
patchPoints = map last (List.groupBy sameMinor allVersions)
in (latest, V.bumpMajor latest, M.MAJOR)
: map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
in (latest, V.bumpMajor latest, M.MAJOR) :
map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
sameMajor :: V.Version -> V.Version -> Bool
@ -57,21 +47,4 @@ installPackageVersion cache pkg vsn = do
if versionedPkgExists
then return $ Right ()
else do
let basePkgPath = Dirs.basePackage cache pkg
basePkgExists <- Dir.doesDirectoryExist basePkgPath
if basePkgExists
then do
updateResult <- Git.update pkg basePkgPath
case updateResult of
Left updateErr ->
return $ Left updateErr
Right () ->
Git.localClone basePkgPath vsn versionedPkgPath
else do
let gitUrl = Git.githubUrl pkg
baseCloneResult <- Git.clone gitUrl basePkgPath
case baseCloneResult of
Left cloneErr ->
return $ Left cloneErr
Right () ->
Git.localClone basePkgPath vsn versionedPkgPath
Git.clone (Git.githubUrl pkg) vsn versionedPkgPath

View File

@ -196,8 +196,8 @@ addConstraint solved unsolved (name, newConstraint) =
getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
getRelevantVersions name constraint =
Solver $ \state@(State cache _) ok back err -> do
versionsResult <- Package.getVersions cache name
Solver $ \state@(State _ _) ok back err -> do
versionsResult <- Package.getVersions name
case versionsResult of
Right (newest, previous) ->
case filter (C.satisfies constraint) (newest : previous) of

View File

@ -4,8 +4,6 @@ module Git
--
githubUrl,
clone,
localClone,
update,
tags,
--
hasLocalTag,
@ -13,9 +11,11 @@ module Git
)
where
import Data.ByteString.Char8 qualified as BS
import Data.Either qualified as Either
import Data.List qualified as List
import Data.Maybe qualified as Maybe
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Gren.Package qualified as Pkg
import Gren.Version qualified as V
import Parse.Primitives qualified as Parser
@ -27,7 +27,7 @@ import System.Process qualified as Process
data Error
= MissingGit
| FailedCommand (Maybe FilePath) [String] String
| NoVersions FilePath
| NoVersions
--
@ -53,43 +53,21 @@ githubUrl pkg =
--
clone :: GitUrl -> FilePath -> IO (Either Error ())
clone (GitUrl (pkgName, gitUrl)) targetFolder = do
maybeExec <- checkInstalledGit
putStrFlush $ "Cloning " ++ pkgName ++ "... "
case maybeExec of
Nothing -> do
putStrLn "Error!"
return $ Left MissingGit
Just git -> do
let args = ["clone", "--bare", gitUrl, targetFolder]
(exitCode, _, stderr) <-
Process.readCreateProcessWithExitCode
(Process.proc git args)
""
case exitCode of
Exit.ExitFailure _ -> do
putStrLn "Error!"
return $ Left $ FailedCommand Nothing ("git" : args) stderr
Exit.ExitSuccess -> do
putStrLn "Ok!"
return $ Right ()
localClone :: FilePath -> V.Version -> FilePath -> IO (Either Error ())
localClone gitUrl vsn targetFolder = do
clone :: GitUrl -> V.Version -> FilePath -> IO (Either Error ())
clone (GitUrl (pkgName, gitUrl)) vsn targetFolder = do
maybeExec <- checkInstalledGit
putStrFlush $ "Cloning " ++ pkgName ++ " " ++ V.toChars vsn ++ "... "
case maybeExec of
Nothing ->
return $ Left MissingGit
Just git -> do
let args =
[ "clone",
gitUrl,
"--local",
"-b",
"--branch",
V.toChars vsn,
"--depth",
"1",
gitUrl,
targetFolder
]
(exitCode, _, stderr) <-
@ -100,62 +78,61 @@ localClone gitUrl vsn targetFolder = do
Exit.ExitFailure _ -> do
putStrLn "Error!"
return $ Left $ FailedCommand Nothing ("git" : args) stderr
Exit.ExitSuccess ->
return $ Right ()
update :: Pkg.Name -> FilePath -> IO (Either Error ())
update pkg path = do
maybeExec <- checkInstalledGit
putStrFlush $ "Updating " ++ Pkg.toChars pkg ++ "... "
case maybeExec of
Nothing -> do
putStrLn "Error!"
return $ Left MissingGit
Just git -> do
let args = ["fetch", "-t"]
(exitCode, _, stderr) <-
Process.readCreateProcessWithExitCode
( (Process.proc git args)
{ Process.cwd = Just path
}
)
""
case exitCode of
Exit.ExitFailure _ -> do
putStrLn "Error!"
return $ Left $ FailedCommand (Just path) ("git" : args) stderr
Exit.ExitSuccess -> do
putStrLn "Ok!"
return $ Right ()
tags :: FilePath -> IO (Either Error (V.Version, [V.Version]))
tags path = do
tags :: GitUrl -> IO (Either Error (V.Version, [V.Version]))
tags (GitUrl (pkgName, gitUrl)) = do
maybeExec <- checkInstalledGit
putStrFlush $ "Retrieving versions for " ++ pkgName ++ "... "
case maybeExec of
Nothing ->
return $ Left MissingGit
Just git -> do
let args = ["tag"]
let args =
[ "ls-remote",
"--tags",
gitUrl
]
(exitCode, stdout, stderr) <-
Process.readCreateProcessWithExitCode
( (Process.proc git args)
{ Process.cwd = Just path
}
)
(Process.proc git args)
""
case exitCode of
Exit.ExitFailure _ -> do
return $ Left $ FailedCommand (Just path) ("git" : args) stderr
putStrLn "Error!"
return $ Left $ FailedCommand Nothing ("git" : args) stderr
Exit.ExitSuccess ->
let tagList =
map BS.pack $ lines stdout
map (TE.encodeUtf8) $
map (Text.replace (Text.pack "refs/tags/") Text.empty) $
map (Text.pack) $
map (Maybe.fromMaybe "" . listGet 1) $
map words $
lines stdout
-- Ignore tags that aren't semantic versions
versions =
reverse $ List.sort $ Either.rights $ map (Parser.fromByteString V.parser (,)) tagList
in case versions of
[] -> return $ Left $ NoVersions path
v : vs -> return $ Right (v, vs)
reverse $
List.sort $
Either.rights $ -- Ignore tags that aren't semantic versions
map (Parser.fromByteString V.parser (,)) tagList
in do
putStrLn "Ok!"
return $ case versions of
[] -> Left NoVersions
v : vs -> Right (v, vs)
listGet :: Int -> [a] -> Maybe a
listGet idx ls =
case ls of
[] -> Nothing
first : rest ->
if idx == 0
then Just first
else listGet (idx - 1) rest
--
hasLocalTag :: V.Version -> IO (Either Error ())
hasLocalTag vsn = do

View File

@ -1888,9 +1888,9 @@ toGitErrorReport title err context =
[ D.reflow "But it returned the following error message:",
D.indent 4 $ D.reflow errorMsg
]
Git.NoVersions _ ->
Git.NoVersions ->
toGitReport
(context ++ ", no valid semantic version tags in this repo.")
(context ++ ", no semver compatible tags in this repo.")
[ D.reflow
"Gren packages are just git repositories with tags following the \
\ semantic versioning scheme. However, it seems that this particular repo \

View File

@ -50,9 +50,6 @@ Common gren-common
terminal/impl
terminal/src
other-extensions:
TemplateHaskell
other-modules:
Bump
Diff
@ -211,7 +208,8 @@ Common gren-common
scientific,
time >= 1.9.1,
utf8-string,
vector
vector,
text >= 2 && < 3
Executable gren
Import:

View File

@ -59,10 +59,10 @@ getEnv =
-- BUMP
bump :: Env -> Task.Task Exit.Bump ()
bump env@(Env root cache outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
bump env@(Env root _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
Task.eio id $
do
versionResult <- Dirs.withRegistryLock cache $ Package.getVersions cache pkg
versionResult <- Package.getVersions pkg
case versionResult of
Right knownVersions ->
let bumpableVersions =

View File

@ -69,11 +69,11 @@ type Task a =
Task.Task Exit.Diff a
diff :: Env -> Args -> Task ()
diff env@(Env _ cache) args =
diff env@(Env _ _) args =
case args of
GlobalInquiry name v1 v2 ->
do
versionResult <- Task.io $ Dirs.withRegistryLock cache $ Package.getVersions cache name
versionResult <- Task.io $ Package.getVersions name
case versionResult of
Right vsns ->
do
@ -116,7 +116,7 @@ getLatestDocs (Env _ cache) name (latest, _) =
-- READ OUTLINE
readOutline :: Env -> Task (Pkg.Name, (V.Version, [V.Version]))
readOutline (Env maybeRoot cache) =
readOutline (Env maybeRoot _) =
case maybeRoot of
Nothing ->
Task.throw Exit.DiffNoOutline
@ -132,7 +132,7 @@ readOutline (Env maybeRoot cache) =
Task.throw Exit.DiffApplication
Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
do
versionResult <- Task.io $ Dirs.withRegistryLock cache $ Package.getVersions cache pkg
versionResult <- Task.io $ Package.getVersions pkg
case versionResult of
Right vsns ->
return (pkg, vsns)

View File

@ -60,13 +60,13 @@ getEnv =
-- PUBLISH
publish :: Env -> Task.Task Exit.Publish ()
publish env@(Env root cache outline) =
publish env@(Env root _ outline) =
case outline of
Outline.App _ ->
Task.throw Exit.PublishApplication
Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
do
knownVersionsResult <- Task.io $ Dirs.withRegistryLock cache $ Package.getVersions cache pkg
knownVersionsResult <- Task.io $ Package.getVersions pkg
let knownVersionsMaybe = Either.either (const Nothing) Just knownVersionsResult
reportPublishStart pkg vsn knownVersionsMaybe