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