wip

Makefile

@@ -27,6 +27,8 @@ BINS := \
   hbs2-sync          \
   fixme-new          \
 	hbs2-storage-simple-benchmarks \
+	hbs2-git3
+
 
 RT_DIR := tests/RT
 

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

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
 

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