wip

flake.nix

@@ -164,6 +164,7 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
           pkgs.libsodium
           pkgs.file
           pkgs.zlib
+          pkgs.bzip2
           inputs.hspup.packages.${pkgs.system}.default
         ]
       );

hbs2-git3/app/Main.hs

@@ -1,10 +1,21 @@
 {-# Language ViewPatterns #-}
 {-# Language PatternSynonyms #-}
+{-# Language RecordWildCards #-}
 module Main where
 
 import HBS2.Prelude.Plated
 import HBS2.OrDie
-import HBS2.Storage.Compact
+
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client.StorageClient
 
 import HBS2.Git.Local
 import HBS2.Git.Local.CLI
@@ -30,6 +41,7 @@ import Data.ByteString qualified as BS
 import Data.ByteString.Lazy (ByteString)
 import Text.InterpolatedString.Perl6 (qc)
 import Data.HashSet qualified as HS
+import Data.HashSet (HashSet(..))
 import Data.HashMap.Strict qualified as HM
 import Data.Word
 
@@ -38,14 +50,18 @@ 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 Control.Monad.Reader
+import System.IO (hPrint,hGetLine,IOMode(..))
+import System.IO qualified as IO
 
+import Data.Kind
 import Data.List (sortOn)
 import Data.Ord (Down(..))
 
 import UnliftIO
 
 {- HLINT ignore "Functor law" -}
+{- HLINT ignore "Eta reduce" -}
 
 type HBS2GitPerks m = (MonadUnliftIO  m)
 
@@ -56,6 +72,7 @@ data GitException =
     CompressionError String
   | InvalidObjectFormat GitObjectType (Maybe GitHash)
   | InvalidGitPack ByteString
+  | OtherGitError String
   deriving stock (Eq,Show,Typeable,Generic)
 
 instance Exception GitException
@@ -99,7 +116,7 @@ gitReadObjectThrow t h = do
   gitRunCommand [qc|git cat-file {pretty t} {pretty h}|]
     >>= orThrowPassIO
 
-gitRevParse :: MonadIO m => GitRef -> m (Maybe GitHash)
+gitRevParse :: (Pretty ref, MonadIO m) => ref -> m (Maybe GitHash)
 gitRevParse ref = do
   gitRunCommand [qc|git rev-parse {pretty ref}|]
     >>= orThrowPassIO
@@ -124,7 +141,179 @@ instance Pretty (Short GitObjectType) where
 
 
 sortGitTreeEntries :: [GitTreeEntry] -> [GitTreeEntry]
-sortGitTreeEntries = sortOn (\entry -> (gitEntryType entry, gitEntrySize entry))
+sortGitTreeEntries = sortOn (\e -> (gitEntryType e, gitEntrySize e))
+
+class GitWritePacksOpts a where
+  excludeParents :: a -> Bool
+
+instance GitWritePacksOpts () where
+  excludeParents = const True
+
+data GitWritePacksOptVal =
+  WriteFullPack
+  deriving stock (Eq,Ord,Show,Generic)
+
+instance Hashable GitWritePacksOptVal
+
+instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where
+  excludeParents o = not $ HS.member WriteFullPack o
+
+data Git3Exception =
+  Git3PeerNotConnected
+  deriving (Show,Typeable,Generic)
+
+instance Exception Git3Exception
+
+data Git3Env =
+    Git3Disconnected
+  | Git3Connected
+    { peerSocket  :: FilePath
+    , peerAPI :: ServiceCaller PeerAPI UNIX
+    }
+
+newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a }
+                   deriving newtype ( Applicative
+                                    , Functor
+                                    , Monad
+                                    , MonadIO
+                                    , MonadUnliftIO
+                                    , MonadReader Git3Env
+                                    )
+
+type Git3Perks m = ( MonadIO m
+                   , MonadUnliftIO m
+                   )
+
+
+instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where
+  getClientAPI = do
+    ask  >>= \case
+       Git3Disconnected -> throwIO Git3PeerNotConnected
+       Git3Connected{..} -> pure peerAPI
+
+instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where
+  getClientAPI = lift (getClientAPI @api @proto)
+
+instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
+  getClientAPI = lift $ getClientAPI @api @proto
+
+nullGit3Env :: MonadIO m => m Git3Env
+nullGit3Env = pure Git3Disconnected
+
+withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a
+withGit3Env env a = runReaderT (fromGit3 a) env
+
+runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b
+runGit3 env action = withGit3Env env action
+
+recover :: Git3 IO a -> Git3 IO a
+recover m = fix \again -> do
+  catch m $ \case
+    Git3PeerNotConnected -> do
+
+      soname <- detectRPC
+                  `orDie` "can't locate hbs2-peer rpc"
+
+      flip runContT pure do
+
+        client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+                    >>= orThrowUser ("can't connect to" <+> pretty soname)
+
+        void $ ContT $ withAsync $ runMessagingUnix client
+
+        peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+        refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+        storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+        lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
+
+        -- let sto = AnyStorage (StorageClient storageAPI)
+
+        let endpoints = [ Endpoint @UNIX  peerAPI
+                        , Endpoint @UNIX  refLogAPI
+                        , Endpoint @UNIX  lwwAPI
+                        , Endpoint @UNIX  storageAPI
+                        ]
+
+        void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+        let connected = Git3Connected soname peerAPI
+
+        liftIO $ withGit3Env connected again
+
+gitWriteCommitPackIO :: (GitWritePacksOpts opt, Pretty what) => opt -> what -> ( BS.ByteString -> IO () ) -> IO ()
+gitWriteCommitPackIO opts what action = do
+    hhead <- gitRevParse what >>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty what)
+
+    co <- gitReadObjectThrow Commit hhead
+           <&> LBS8.lines
+           <&> takeWhile ( not . LBS8.null )
+           <&> LBS8.unpack . LBS8.unlines
+           <&> parseTop
+           >>= orThrow (OtherGitError "invalid commit format")
+
+    let parents =  [ fromStringMay @GitHash hash
+                   | ListVal [ StringLike "parent", StringLike hash ] <- co
+                   ] & catMaybes
+
+    -- debug $ "EXCLUDE PARENTS" <+> pretty (excludeParents opts)
+
+    skip <- if not (excludeParents opts) then do
+                 pure mempty
+               else do
+                  skip' <- S.toList_ $ for parents $ \p -> do
+                            gitReadTree p <&> fmap gitEntryHash >>= S.each
+                  pure $ 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 params = defaultCompressParams
+      let compressStream = BZ.compressIO params
+
+      lift $ flip fix compressStream $ \go -> \case
+        BZ.CompressInputRequired next -> do
+
+         inO <- atomically $ tryReadTQueue inq
+
+         case inO of
+          Nothing -> go =<< 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 & orThrow (OtherGitError "git cat-file --batch error")
+                co <- liftIO $ LBS.hGet ssout n
+                void $ liftIO $ hGetLine ssout
+                let header = [qc|{pretty (Short t)} {s} {pretty ha}|]
+                go =<< next (LBS.toStrict (LBS8.intercalate "\n" [header, co]))
+
+              e -> throwIO $ OtherGitError ("git cat-file --batch error: " <> show e)
+
+        BZ.CompressOutputAvailable outchunk next -> do
+         action outchunk
+         go =<< next
+
+        BZ.CompressStreamEnd -> pure ()
 
 data UState =
   UHead ByteString
@@ -140,7 +329,7 @@ unpackPEntry = \case
   _ -> Nothing
 
 theDict :: forall m . ( HBS2GitPerks m
-                      -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m
+                      , HasClientAPI PeerAPI UNIX m
                       ) => Dict C m
 theDict = do
   makeDict @C do
@@ -181,81 +370,32 @@ theDict = do
 
           _ -> 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 ]
+        entry $ bindMatch "test:hbs2:peer:poke" $ nil_ $ \syn -> do
+          peer <- getClientAPI @PeerAPI @UNIX
+          r    <- callRpcWaitRetry @RpcPoke (TimeoutSec 0.5) 2 peer () >>= orThrowUser "hbs2-peer not found"
+          notice $ pretty r
 
-          hhead <- gitRevParse co >>= orThrowUser ("can't parse" <+> pretty co)
+        entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> flip runContT pure do
+          pure ()
 
-          co <- gitReadObjectThrow Commit hhead
+        entry $ bindMatch "test:git:tree:pack:write" $ nil_ $ \syn -> flip runContT pure do
-                 <&> LBS8.lines
-                 <&> takeWhile ( not . LBS8.null )
-                 <&> LBS8.unpack . LBS8.unlines
-                 <&> parseTop
-                 >>= orThrowUser "invalid commit format"
 
-          let parents =  [ fromStringMay @GitHash hash
+          let o = [ WriteFullPack | StringLike "--full" <- syn ] & HS.fromList
-                         | ListVal [ StringLike "parent", StringLike hash ] <- co
-                         ] & catMaybes
 
-          skip' <- S.toList_ $ for parents $ \p -> do
+          (what,to) <- case syn of
-                    gitReadTree p <&> fmap gitEntryHash >>= S.each
 
-          let skip = HS.fromList skip'
+             ( StringLike rev : StringLike fn : _) -> do
+              -- let co = headDef "HEAD" $ [ GitRef (LBS8.toStrict $ LBS8.pack what) | StringLike what  <- syn ]
+               fh <- ContT $ bracket (liftIO (IO.openFile fn WriteMode)) hClose
+               pure (rev, fh)
 
-          r <- gitReadTree hhead
+             ( StringLike rev : _ ) -> pure  ( rev, stdout )
-                 <&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip))
-                 <&> sortGitTreeEntries
 
-          flip runContT pure do
+             _ -> pure ( "HEAD", stdout )
-            ph <- ContT withGitCat
-            let ssin  = getStdin ph
-            let ssout = getStdout ph
 
-            inq <- newTQueueIO
+          liftIO $ gitWriteCommitPackIO o what $ \bs -> do
-
+            BS.hPut to bs
-            atomically do
-              writeTQueue inq (Commit, hhead)
-              for_ r $ \GitTreeEntry{..} -> do
-                writeTQueue inq (gitEntryType, gitEntryHash)
-
-            let
-                go ::  Handle -> BZ.CompressStream IO -> IO ()
-                go outh (BZ.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 (BZ.CompressOutputAvailable outchunk next) = do
-                   BS.hPut outh outchunk
-                   go outh =<< next
-                go _ BZ.CompressStreamEnd = return ()
-
-            let params = defaultCompressParams
-            let compressStream = BZ.compressIO params
-
-            liftIO $ go stdout compressStream
-
-            none
 
 -- debugPrefix :: LoggerEntry -> LoggerEntry
 debugPrefix = toStderr . logPrefix "[debug] "
@@ -279,8 +419,6 @@ silence = do
   setLoggingOff @WARN
   setLoggingOff @NOTICE
 
-
-
 main :: IO ()
 main = flip runContT pure do
 
@@ -293,8 +431,9 @@ main = flip runContT pure do
   cli <- parseTop (unlines $ unwords <$> splitForms argz)
            & either  (error.show) pure
 
+  env <- nullGit3Env
+
+  void $ lift $ withGit3Env env do
     let dict = theDict
-
+    recover $ run dict cli
-  void $ lift $ run dict cli
-
 

hbs2-git3/hbs2-git3.cabal

@@ -0,0 +1,136 @@
+cabal-version:      3.0
+name:               hbs2-git3
+version:            0.24.1.2
+synopsis: reimplemented fixme
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+-- copyright:
+category:           System
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common shared-properties
+  ghc-options:
+        -Wall
+        -fno-warn-type-defaults
+        -threaded
+        -rtsopts
+        -O2
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+  default-language: GHC2021
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , RecordWildCards
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+
+
+  build-depends:
+        hbs2-core
+      , hbs2-peer
+      , hbs2-storage-simple
+      , hbs2-keyman-direct-lib
+      , hbs2-git
+      , hbs2-cli
+      , db-pipe
+      , suckless-conf
+      , fuzzy-parse
+
+      , aeson
+      , aeson-pretty
+      , attoparsec
+      , atomic-write
+      , bytestring
+      , binary
+      , containers
+      , directory
+      , exceptions
+      , filepath
+      , filepattern
+      , generic-lens
+      , generic-deriving
+      , interpolatedstring-perl6
+      , memory
+      , microlens-platform
+      , mtl
+      , safe
+      , serialise
+      , scientific
+      , streaming
+      , stm
+      , split
+      , text
+      , temporary
+      , time
+      , timeit
+      , transformers
+      , typed-process
+      , unordered-containers
+      , unliftio
+      , unliftio-core
+      , zlib
+      , prettyprinter
+      , prettyprinter-ansi-terminal
+      , random
+      , vector
+      , unix
+      , uuid
+
+
+library
+    import:           shared-properties
+
+    other-modules:
+
+    exposed-modules:
+
+    build-depends:    base
+                    , base16-bytestring
+                    , binary
+                    , bzlib
+                    , unix
+
+    hs-source-dirs:  lib
+
+
+executable hbs2-git3
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
+        , bzlib
+        , binary
+        , vector
+
+    hs-source-dirs:   app
+    default-language: GHC2021
+
+