mirror of https://github.com/voidlizard/hbs2
322 lines
9.6 KiB
Haskell
322 lines
9.6 KiB
Haskell
module HBS2.Git3.Git
|
|
( module HBS2.Git3.Git
|
|
, module HBS2.Git.Local
|
|
, module HBS2.Git.Local.CLI
|
|
) where
|
|
|
|
import HBS2.Git3.Prelude
|
|
import HBS2.OrDie
|
|
|
|
import HBS2.Git3.Types
|
|
import HBS2.Git3.State.Internal.Types
|
|
import HBS2.Git.Local
|
|
import HBS2.Git.Local.CLI
|
|
|
|
import Data.Config.Suckless.Script
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
import Crypto.Hash (hashlazy)
|
|
import Crypto.Hash qualified as Crypton
|
|
import Data.ByteArray qualified as BA
|
|
import Data.ByteString qualified as BS
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.ByteString.Lazy ( ByteString )
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.Either
|
|
import Data.HashSet qualified as HS
|
|
import Data.HashSet (HashSet)
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.HashPSQ (HashPSQ)
|
|
import Data.HashPSQ qualified as HPSQ
|
|
import Data.List (sortOn)
|
|
import Data.Maybe
|
|
import Data.Word
|
|
import System.FilePath
|
|
import System.IO (hPrint,hGetLine)
|
|
import System.Process.Typed
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
import UnliftIO
|
|
|
|
{-HLINT Ignore "Functor law"-}
|
|
|
|
|
|
data GitException =
|
|
CompressionError String
|
|
| DecompressionError String
|
|
| InvalidObjectFormat GitObjectType (Maybe GitHash)
|
|
| InvalidGitPack ByteString
|
|
| OtherGitError String
|
|
| UnknownRev String
|
|
| GitReadError String
|
|
| GitImportError String
|
|
deriving stock (Eq,Show,Typeable,Generic)
|
|
|
|
instance Exception GitException
|
|
|
|
data GitTreeEntry =
|
|
GitTreeEntry
|
|
{ gitEntryAttribs :: Word16
|
|
, gitEntryType :: GitObjectType
|
|
, gitEntryHash :: GitHash
|
|
, gitEntrySize :: Maybe Word32
|
|
, gitEntryName :: FilePath
|
|
}
|
|
deriving (Show)
|
|
|
|
pattern GitTreeEntryView :: GitTreeEntry -> [ByteString]
|
|
pattern GitTreeEntryView e <- (isGitLsTreeEntry -> Just e)
|
|
|
|
gitNormaliseRef :: GitRef -> GitRef
|
|
gitNormaliseRef r@(GitRef what) =
|
|
if BS8.isPrefixOf "refs/" what || what == "HEAD" then
|
|
r
|
|
else
|
|
fromString (joinPath $ splitPath $ "refs" </> "heads" </> BS8.unpack what)
|
|
|
|
isGitLsTreeEntry :: [ByteString] -> Maybe GitTreeEntry
|
|
isGitLsTreeEntry = \case
|
|
[sa,st,sh,ss,sn] -> do
|
|
GitTreeEntry <$> readMay @Word16 (LBS8.unpack sa)
|
|
<*> fromStringMay (LBS8.unpack st)
|
|
<*> fromStringMay (LBS8.unpack sh)
|
|
<*> pure (readMay (LBS8.unpack ss))
|
|
<*> pure (LBS8.unpack sn)
|
|
|
|
_ -> Nothing
|
|
|
|
gitReadTreeObjectsOnly :: (Pretty what, MonadIO m) => what -> m [GitHash]
|
|
gitReadTreeObjectsOnly what =
|
|
gitRunCommand [qc|git ls-tree -t -r --object-only {pretty what}|]
|
|
>>= orThrow (GitReadError (show $ pretty what))
|
|
<&> fmap LBS8.words . LBS8.lines
|
|
<&> mapMaybe \case
|
|
[ x ] -> fromStringMay @GitHash (LBS8.unpack x)
|
|
_ -> Nothing
|
|
|
|
gitReadTree :: (Pretty what, MonadIO m) => what -> m [GitTreeEntry]
|
|
gitReadTree what =
|
|
gitRunCommand [qc|git ls-tree -t -l -r {pretty what}|]
|
|
>>= orThrow (GitReadError (show $ pretty what))
|
|
<&> fmap LBS8.words . LBS8.lines
|
|
<&> mapMaybe \case
|
|
GitTreeEntryView v -> do
|
|
Just v
|
|
_ -> Nothing
|
|
<&> \s -> HM.elems (HM.fromList [ (gitEntryHash e, e) | e <- s])
|
|
|
|
class GitObjectReader a where
|
|
gitReadObjectMaybe :: forall m . MonadIO m => a -> GitHash -> m (Maybe (GitObjectType, ByteString))
|
|
|
|
gitReadObjectOrThrow :: forall m a . (MonadIO m, GitObjectReader a) => a -> GitHash -> m (GitObjectType, ByteString)
|
|
gitReadObjectOrThrow r co =
|
|
gitReadObjectMaybe r co >>= orThrow (GitReadError (show $ pretty co))
|
|
|
|
gitReadObjectThrow :: (Pretty h, MonadIO m) => GitObjectType -> h -> m ByteString
|
|
gitReadObjectThrow t h = do
|
|
gitRunCommand [qc|git cat-file {pretty t} {pretty h}|]
|
|
>>= orThrowPassIO
|
|
|
|
gitRevParse :: (Pretty ref, MonadIO m) => ref -> m (Maybe GitHash)
|
|
gitRevParse ref = do
|
|
gitRunCommand [qc|git rev-parse {pretty ref}|]
|
|
>>= orThrowPassIO
|
|
<&> LBS8.words
|
|
<&> maybe Nothing (fromStringMay . LBS8.unpack) . headMay
|
|
|
|
gitRevParseThrow :: (Pretty ref, MonadIO m) => ref -> m GitHash
|
|
gitRevParseThrow r = gitRevParse r >>= orThrow (UnknownRev (show $ pretty r))
|
|
|
|
gitImportObjectSlow :: MonadIO m => GitObjectType -> ByteString -> m (Either ExitCode ())
|
|
gitImportObjectSlow t lbs = do
|
|
let cmd = "git"
|
|
let args = ["hash-object", "-w", "--stdin", "-t", (show $ pretty t)]
|
|
let config = setStdin (byteStringInput lbs) $ setStdout closed $ setStderr closed $ proc cmd args
|
|
code <- runProcess config
|
|
pure $ if (code /= ExitSuccess) then Left code else Right ()
|
|
|
|
gitReadHEAD :: MonadIO m => m (Maybe GitRef)
|
|
gitReadHEAD = runMaybeT do
|
|
gitRunCommand [qc|git symbolic-ref HEAD|]
|
|
>>= toMPlus
|
|
<&> headMay . LBS8.lines
|
|
>>= toMPlus
|
|
<&> GitRef . LBS8.toStrict
|
|
|
|
withGitCat :: (MonadIO m) => (Process Handle Handle () -> m a) -> m a
|
|
withGitCat action = do
|
|
p <- startGitCat
|
|
action p
|
|
|
|
startGitCat :: MonadIO m => m (Process Handle Handle ())
|
|
startGitCat = do
|
|
let cmd = "git"
|
|
let args = ["cat-file", "--batch"]
|
|
let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
|
|
startProcess config
|
|
|
|
withGitCatCheck :: (MonadIO m) => (Process Handle Handle () -> m a) -> m a
|
|
withGitCatCheck action = do
|
|
let cmd = "git"
|
|
let args = ["cat-file", "--batch-check"]
|
|
let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
|
|
p <- startProcess config
|
|
action p
|
|
|
|
|
|
withGitShowIndex :: (MonadIO m) => (Process Handle Handle () -> m a) -> m a
|
|
withGitShowIndex action = do
|
|
let cmd = "git"
|
|
let args = ["show-index"]
|
|
let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
|
|
p <- startProcess config
|
|
action p
|
|
|
|
gitCheckObjectFromHandle :: MonadIO m => Process Handle Handle a -> GitHash -> m (Maybe (GitObjectType, Int))
|
|
gitCheckObjectFromHandle ph gh = liftIO do
|
|
|
|
let ssin = getStdin ph
|
|
let ssout = getStdout ph
|
|
|
|
hPrint ssin (pretty gh) >> hFlush ssin
|
|
|
|
s <- hGetLine ssout
|
|
|
|
runMaybeT do
|
|
|
|
case words s of
|
|
[_,t,ss] -> do
|
|
n <- readMay @Int ss & toMPlus
|
|
o <- fromStringMay @GitObjectType t & toMPlus
|
|
pure $ (o,n)
|
|
|
|
[_,"missing"] -> do
|
|
mzero
|
|
|
|
w -> throwIO (GitReadError $ show (pretty w))
|
|
|
|
|
|
gitReadCommitParents :: MonadIO m => Maybe GitHash -> ByteString -> m [GitHash]
|
|
gitReadCommitParents _ bs = do
|
|
pure $ LBS8.lines bs
|
|
& takeWhile ( not . LBS8.null )
|
|
& fmap (words . LBS8.unpack)
|
|
& mapMaybe \case
|
|
["parent", x] -> fromStringMay @GitHash x
|
|
_ -> Nothing
|
|
|
|
gitReadCommitTree :: MonadIO m => ByteString -> m GitHash
|
|
gitReadCommitTree bs = do
|
|
|
|
what <- LBS8.lines bs
|
|
& takeWhile ( not . LBS8.null )
|
|
& LBS8.unpack . LBS8.unlines
|
|
& parseTop
|
|
& orThrow (OtherGitError "invalid commit format")
|
|
|
|
let r = [ fromStringMay @GitHash hash
|
|
| ListVal [ StringLike "tree", StringLike hash ] <- what
|
|
]
|
|
|
|
catMaybes r & headMay & orThrow (InvalidObjectFormat Commit Nothing)
|
|
|
|
gitObjectExists :: (MonadIO m, Pretty what) => what -> m Bool
|
|
gitObjectExists what = do
|
|
gitRunCommand [qc|git cat-file -e {pretty what}|] <&> isRight
|
|
|
|
|
|
instance GitObjectReader (Process Handle Handle ()) where
|
|
gitReadObjectMaybe ph co = liftIO do
|
|
|
|
let ssin = getStdin ph
|
|
let ssout = getStdout ph
|
|
|
|
hPrint ssin $ pretty co
|
|
hFlush ssin
|
|
|
|
s <- hGetLine ssout
|
|
|
|
runMaybeT do
|
|
|
|
case words s of
|
|
[_,t,ss] -> do
|
|
n <- readMay @Int ss & toMPlus
|
|
o <- fromStringMay @GitObjectType t & toMPlus
|
|
bs <- lift $ LBS.hGet ssout n
|
|
void $ lift $ hGetLine ssout
|
|
pure (o,bs)
|
|
|
|
[_,"missing"] -> do
|
|
mzero
|
|
|
|
w -> throwIO (GitReadError $ show (pretty w))
|
|
|
|
|
|
sortGitTreeEntries :: [GitTreeEntry] -> [GitTreeEntry]
|
|
sortGitTreeEntries = sortOn (\e -> (gitEntryType e, gitEntrySize e))
|
|
|
|
sha1lazy :: ByteString -> BS.ByteString
|
|
sha1lazy lbs = BS.pack $ BA.unpack $ hashlazy @Crypton.SHA1 lbs
|
|
|
|
gitHashBlobPure :: ByteString -> GitHash
|
|
gitHashBlobPure body = do
|
|
let preamble = [qc|{pretty Blob} {pretty $ LBS.length body}|] <> "\x00" :: LBS8.ByteString
|
|
GitHash $ BS.pack $ BA.unpack $ hashlazy @Crypton.SHA1 (preamble <> body)
|
|
|
|
|
|
|
|
data HCC =
|
|
HCC { hccHeight :: Int
|
|
, hccRest :: [GitHash]
|
|
, hccResult :: HashPSQ GitHash Int (HashSet GitHash)
|
|
}
|
|
|
|
readCommitChainHPSQ :: ( HBS2GitPerks m
|
|
, MonadUnliftIO m
|
|
, MonadReader Git3Env m
|
|
, HasStorage m
|
|
)
|
|
=> (GitHash -> m Bool)
|
|
-> Maybe GitRef
|
|
-> GitHash
|
|
-> (GitHash -> m ())
|
|
-> m (HashPSQ GitHash Int (HashSet GitHash))
|
|
|
|
readCommitChainHPSQ filt _ h0 action = flip runContT pure $ callCC \_ -> do
|
|
theReader <- ContT $ withGitCat
|
|
void $ ContT $ bracket (pure theReader) dontHandle -- stopProcess
|
|
flip fix (HCC 0 [h0] HPSQ.empty) $ \next -> \case
|
|
|
|
HCC _ [] result -> pure result
|
|
|
|
HCC n ( h : hs ) result | HPSQ.member h result -> do
|
|
next ( HCC n hs result )
|
|
|
|
HCC n ( h : hs ) result -> do
|
|
|
|
done <- not <$> lift (filt h)
|
|
|
|
if done then next ( HCC n hs result ) else do
|
|
|
|
co <- gitReadObjectMaybe theReader h
|
|
>>= orThrow(GitReadError $ show $ pretty "object not found" <+> pretty h)
|
|
|
|
parents <- gitReadCommitParents (Just h) (snd co)
|
|
|
|
lift $ action h
|
|
next $ HCC (n-1) ( parents <> hs ) (snd $ HPSQ.alter (addParents () n parents) h result )
|
|
|
|
|
|
where
|
|
addParents :: a
|
|
-> Int
|
|
-> [GitHash]
|
|
-> Maybe (Int, HashSet GitHash)
|
|
-> (a, Maybe (Int, HashSet GitHash))
|
|
|
|
addParents a n p = \case
|
|
Nothing -> (a, Just (n, HS.fromList p))
|
|
Just (l,s) -> (a, Just (min l n, s <> HS.fromList p))
|
|
|
|
|