diff --git a/Makefile b/Makefile index a2873fa4..cb21fc92 100644 --- a/Makefile +++ b/Makefile @@ -27,6 +27,8 @@ BINS := \ hbs2-sync \ fixme-new \ hbs2-storage-simple-benchmarks \ + hbs2-git3 + RT_DIR := tests/RT diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 73ba1011..d684e0a2 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/hbs2-core/lib/HBS2/Storage.hs @@ -61,7 +61,6 @@ class ( Monad m delRef :: (Hashed h k, RefMetaData k) => a -> k -> m () - data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO ) => AnyStorage zu @@ -89,9 +88,6 @@ instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m wh delRef (AnyStorage s) = liftIO . delRef s - - - calcChunks :: forall a b . (Integral a, Integral b) => Integer -- | block size -> Integer -- | chunk size diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs index 37b87342..c0024429 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs @@ -46,7 +46,7 @@ instance Pretty GitRef where pretty (GitRef x) = pretty @String [qc|{x}|] data GitObjectType = Commit | Tree | Blob - deriving stock (Eq,Ord,Show,Generic) + deriving stock (Eq,Ord,Show,Generic,Enum) instance Serialise GitObjectType diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs new file mode 100644 index 00000000..e19c5a41 --- /dev/null +++ b/hbs2-git3/app/Main.hs @@ -0,0 +1,296 @@ +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +module Main where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.Storage.Compact + +import HBS2.Git.Local +import HBS2.Git.Local.CLI + +import HBS2.System.Logger.Simple.ANSI as Exported +import HBS2.System.Dir +import HBS2.Misc.PrettyStuff as Exported + +import Data.Config.Suckless.Script + +import Codec.Compression.Zstd qualified as Z + +import Codec.Compression.GZip qualified as GZ1 +import Codec.Compression.Zlib.Internal qualified as GZ + +import Data.Maybe +import Data.List qualified as L +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString qualified as BS +import Data.ByteString.Lazy (ByteString) +import Text.InterpolatedString.Perl6 (qc) +import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM +import Data.Word + +import Streaming.Prelude qualified as S +import System.Exit qualified as Q +import System.Environment qualified as E +import System.Process.Typed +import Control.Monad.Trans.Cont +import System.IO (hPrint,hGetLine) + +import Data.List (sortOn) +import Data.Ord (Down(..)) + +import UnliftIO + +{- HLINT ignore "Functor law" -} + +type HBS2GitPerks m = (MonadUnliftIO m) + +quit :: MonadUnliftIO m => m () +quit = liftIO Q.exitSuccess + +data GitException = + CompressionError String + | InvalidObjectFormat GitObjectType (Maybe GitHash) + | InvalidGitPack ByteString + deriving stock (Eq,Show,Typeable,Generic) + +instance Exception GitException + +data GitTreeEntry = + GitTreeEntry + { gitEntryAttribs :: Word16 + , gitEntryType :: GitObjectType + , gitEntryHash :: GitHash + , gitEntrySize :: Maybe Word32 + , gitEntryName :: FilePath + } + +pattern GitTreeEntryView :: GitTreeEntry -> [ByteString] +pattern GitTreeEntryView e <- (isGitLsTreeEntry -> Just e) + +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 + +gitReadTree :: (Pretty what, MonadIO m) => what -> m [GitTreeEntry] +gitReadTree what = + gitRunCommand [qc|git ls-tree -t -l -r {pretty what}|] + >>= orThrowPassIO + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe \case + GitTreeEntryView v -> do + Just v + _ -> Nothing + +gitReadObjectThrow :: (Pretty h, MonadIO m) => GitObjectType -> h -> m ByteString +gitReadObjectThrow t h = do + gitRunCommand [qc|git cat-file {pretty t} {pretty h}|] + >>= orThrowPassIO + +gitRevParse :: MonadIO m => GitRef -> m (Maybe GitHash) +gitRevParse ref = do + gitRunCommand [qc|git rev-parse {pretty ref}|] + >>= orThrowPassIO + <&> LBS8.words + <&> maybe Nothing (fromStringMay . LBS8.unpack) . headMay + +withGitCat :: (MonadIO m) => (Process Handle Handle () -> m a) -> m a +withGitCat action = do + let cmd = "git" + let args = ["cat-file", "--batch"] + let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args + p <- startProcess config + action p + +newtype Short x = Short x + +instance Pretty (Short GitObjectType) where + pretty = \case + (Short Tree) -> "T" + (Short Blob) -> "B" + (Short Commit) -> "C" + + +sortGitTreeEntries :: [GitTreeEntry] -> [GitTreeEntry] +sortGitTreeEntries = sortOn (\entry -> (gitEntryType entry, gitEntrySize entry)) + +data UState = + UHead ByteString + +pattern PEntryView :: GitObjectType -> Word32 -> GitHash -> [ByteString] +pattern PEntryView t s h <- ( unpackPEntry -> Just (t,s,h) ) + +unpackPEntry :: [ByteString] -> Maybe (GitObjectType, Word32, GitHash) +unpackPEntry = \case + ["C", s, h] -> (Commit,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h) + ["B", s, h] -> (Blob,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h) + ["T", s, h] -> (Tree,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h) + _ -> Nothing + +theDict :: forall m . ( HBS2GitPerks m + -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m + ) => Dict C m +theDict = do + makeDict @C do + -- TODO: write-man-entries + myHelpEntry + where + + myHelpEntry = do + entry $ bindMatch "--help" $ nil_ $ \case + HelpEntryBound what -> do + helpEntry what + quit + + _ -> helpList False Nothing >> quit + + entry $ bindMatch "git:tree:ls" $ nil_ $ const do + r <- gitReadTree "HEAD" + for_ r $ \GitTreeEntry{..} -> do + liftIO $ print $ pretty gitEntryHash <+> pretty gitEntryType <+> pretty gitEntrySize <+> pretty gitEntryName + + entry $ bindMatch "test:git:tree:pack:dump" $ nil_ $ \case + [ StringLike fn ] -> do + + content <- liftIO $ fmap GZ1.decompress (LBS8.readFile fn) + + flip fix (UHead content) $ \next -> \case + UHead "" -> none + UHead bs -> do + + let (hd,rest) = LBS8.span (/='\n') bs + + case LBS8.words hd of + PEntryView t s h -> do + liftIO $ print $ pretty h <+> pretty t <+> pretty s + next $ UHead (LBS8.drop (1 + fromIntegral s) rest) + + _ -> throwIO (InvalidGitPack hd) + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "test:git:tree:pack:write" $ nil_ $ \syn -> do + + let co = headDef "HEAD" $ [ GitRef (LBS8.toStrict $ LBS8.pack what) | StringLike what <- syn ] + + hhead <- gitRevParse co >>= orThrowUser ("can't parse" <+> pretty co) + + co <- gitReadObjectThrow Commit hhead + <&> LBS8.lines + <&> takeWhile ( not . LBS8.null ) + <&> LBS8.unpack . LBS8.unlines + <&> parseTop + >>= orThrowUser "invalid commit format" + + let parents = [ fromStringMay @GitHash hash + | ListVal [ StringLike "parent", StringLike hash ] <- co + ] & catMaybes + + skip' <- S.toList_ $ for parents $ \p -> do + gitReadTree p <&> fmap gitEntryHash >>= S.each + + let skip = HS.fromList skip' + + r <- gitReadTree hhead + <&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip)) + <&> sortGitTreeEntries + + flip runContT pure do + ph <- ContT withGitCat + let ssin = getStdin ph + let ssout = getStdout ph + + inq <- newTQueueIO + + atomically do + writeTQueue inq (Commit, hhead) + for_ r $ \GitTreeEntry{..} -> do + writeTQueue inq (gitEntryType, gitEntryHash) + + let + go :: Handle -> GZ.CompressStream IO -> IO () + go outh (GZ.CompressInputRequired next) = do + + inO <- atomically $ tryReadTQueue inq + + case inO of + Nothing -> go outh =<< next mempty + + Just (t,ha) -> do + + liftIO $ hPrint ssin $ pretty ha + liftIO $ hFlush ssin + + s <- liftIO $ hGetLine ssout + + case words s of + [_,_,s] -> do + n <- readMay @Int s & orThrowUser "fuck!" + co <- liftIO $ LBS.hGet ssout n + void $ liftIO $ hGetLine ssout + let header = [qc|{pretty (Short t)} {s} {pretty ha}|] + go outh =<< next (LBS.toStrict (LBS8.intercalate "\n" [header, co])) + + e -> error (show e) + + go outh (GZ.CompressOutputAvailable outchunk next) = do + BS.hPut outh outchunk + go outh =<< next + go _ GZ.CompressStreamEnd = return () + + let compressStream = GZ.compressIO GZ.gzipFormat GZ.defaultCompressParams + + liftIO $ go stdout compressStream + + none + +-- debugPrefix :: LoggerEntry -> LoggerEntry +debugPrefix = toStderr . logPrefix "[debug] " + +setupLogger :: MonadIO m => m () +setupLogger = do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + +flushLoggers :: MonadIO m => m () +flushLoggers = do + silence + +silence :: MonadIO m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + + + +main :: IO () +main = flip runContT pure do + + setupLogger + + ContT $ bracket none $ const do + silence + + argz <- liftIO $ E.getArgs + cli <- parseTop (unlines $ unwords <$> splitForms argz) + & either (error.show) pure + + let dict = theDict + + void $ lift $ run dict cli + +