From 7528d291c37b1c7627348768cbfac042e2c5a6cf Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 20 Nov 2024 14:29:04 +0300 Subject: [PATCH] wip --- flake.nix | 1 + hbs2-git3/app/Main.hs | 291 ++++++++++++++++++++++++++++---------- hbs2-git3/hbs2-git3.cabal | 136 ++++++++++++++++++ 3 files changed, 352 insertions(+), 76 deletions(-) create mode 100644 hbs2-git3/hbs2-git3.cabal diff --git a/flake.nix b/flake.nix index 702b405d..0de69f0e 100644 --- a/flake.nix +++ b/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 ] ); diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index a7a135a0..9c2dde3a 100644 --- a/hbs2-git3/app/Main.hs +++ b/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 - <&> LBS8.lines - <&> takeWhile ( not . LBS8.null ) - <&> LBS8.unpack . LBS8.unlines - <&> parseTop - >>= orThrowUser "invalid commit format" + entry $ bindMatch "test:git:tree:pack:write" $ nil_ $ \syn -> flip runContT pure do - let parents = [ fromStringMay @GitHash hash - | ListVal [ StringLike "parent", StringLike hash ] <- co - ] & catMaybes + let o = [ WriteFullPack | StringLike "--full" <- syn ] & HS.fromList - skip' <- S.toList_ $ for parents $ \p -> do - gitReadTree p <&> fmap gitEntryHash >>= S.each + (what,to) <- case syn of - 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 - <&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip)) - <&> sortGitTreeEntries + ( StringLike rev : _ ) -> pure ( rev, stdout ) - flip runContT pure do - ph <- ContT withGitCat - let ssin = getStdin ph - let ssout = getStdout ph + _ -> pure ( "HEAD", stdout ) - inq <- newTQueueIO - - 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 + liftIO $ gitWriteCommitPackIO o what $ \bs -> do + BS.hPut to bs -- 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 - let dict = theDict - - void $ lift $ run dict cli + env <- nullGit3Env + void $ lift $ withGit3Env env do + let dict = theDict + recover $ run dict cli diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal new file mode 100644 index 00000000..cf26f7cc --- /dev/null +++ b/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 + +