From a5970a4080a75272c374ee0ff937610748c2fa5d Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 22 Nov 2024 07:20:38 +0300 Subject: [PATCH] modneishe, naprimer --- Makefile | 3 +- hbs2-git3/app/Main.hs | 276 ++++++++++++++++++++++-- hbs2-git3/hbs2-git3.cabal | 24 +++ hbs2-git3/lib/HBS2/Git3/Config/Local.hs | 30 +++ hbs2-git3/lib/HBS2/Git3/State/Direct.hs | 51 +++++ hbs2-git3/lib/HBS2/Git3/State/Types.hs | 16 ++ hbs2-git3/lib/HBS2/Git3/Types.hs | 9 + 7 files changed, 386 insertions(+), 23 deletions(-) create mode 100644 hbs2-git3/lib/HBS2/Git3/Config/Local.hs create mode 100644 hbs2-git3/lib/HBS2/Git3/State/Direct.hs create mode 100644 hbs2-git3/lib/HBS2/Git3/State/Types.hs create mode 100644 hbs2-git3/lib/HBS2/Git3/Types.hs diff --git a/Makefile b/Makefile index cb21fc92..8d356de9 100644 --- a/Makefile +++ b/Makefile @@ -27,7 +27,8 @@ BINS := \ hbs2-sync \ fixme-new \ hbs2-storage-simple-benchmarks \ - hbs2-git3 + hbs2-git3 \ + hbs2-git-daemon RT_DIR := tests/RT diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 9c2dde3a..9ba1d5fd 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -1,10 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language ViewPatterns #-} {-# Language PatternSynonyms #-} {-# Language RecordWildCards #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} module Main where import HBS2.Prelude.Plated import HBS2.OrDie +import HBS2.Base58 import HBS2.Storage import HBS2.Peer.CLI.Detect @@ -24,7 +28,12 @@ import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.System.Dir import HBS2.Misc.PrettyStuff as Exported +import HBS2.Git3.Types +import HBS2.Git3.State.Direct +import HBS2.Git3.Config.Local + import Data.Config.Suckless.Script +import DBPipe.SQLite -- import Codec.Compression.GZip as GZ1 -- import Codec.Compression.Zlib.Internal qualified as GZ @@ -33,6 +42,7 @@ import Codec.Compression.BZip as BZ1 import Codec.Compression.BZip.Internal qualified as BZ -- import Codec.Compression.Zlib.Internal qualified as GZ +import Data.HashPSQ qualified as HPSQ import Data.Maybe import Data.List qualified as L import Data.ByteString.Lazy.Char8 qualified as LBS8 @@ -50,6 +60,7 @@ import System.Exit qualified as Q import System.Environment qualified as E import System.Process.Typed import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe import Control.Monad.Reader import System.IO (hPrint,hGetLine,IOMode(..)) import System.IO qualified as IO @@ -73,6 +84,8 @@ data GitException = | InvalidObjectFormat GitObjectType (Maybe GitHash) | InvalidGitPack ByteString | OtherGitError String + | UnknownRev String + | GitReadError String deriving stock (Eq,Show,Typeable,Generic) instance Exception GitException @@ -111,6 +124,10 @@ gitReadTree what = _ -> 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)) + gitReadObjectThrow :: (Pretty h, MonadIO m) => GitObjectType -> h -> m ByteString gitReadObjectThrow t h = do gitRunCommand [qc|git cat-file {pretty t} {pretty h}|] @@ -123,6 +140,9 @@ gitRevParse ref = do <&> 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)) + withGitCat :: (MonadIO m) => (Process Handle Handle () -> m a) -> m a withGitCat action = do let cmd = "git" @@ -131,6 +151,29 @@ withGitCat action = do p <- startProcess config action p +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) + + _ -> mzero + newtype Short x = Short x instance Pretty (Short GitObjectType) where @@ -166,10 +209,38 @@ instance Exception Git3Exception data Git3Env = Git3Disconnected - | Git3Connected - { peerSocket :: FilePath - , peerAPI :: ServiceCaller PeerAPI UNIX + { gitRefLog :: TVar (Maybe GitRemoteKey) } + | Git3Connected + { stateDb :: DBPipeEnv + , peerSocket :: FilePath + , peerStorage :: AnyStorage + , peerAPI :: ServiceCaller PeerAPI UNIX + , gitRefLog :: TVar (Maybe GitRemoteKey) + } + +class HasGitRemoteKey m where + getGitRemoteKey :: m (Maybe GitRemoteKey) + setGitRemoteKey :: GitRemoteKey -> m () + +instance (MonadIO m, MonadReader Git3Env m) => HasGitRemoteKey m where + getGitRemoteKey = do + e <- ask + liftIO $ readTVarIO (gitRefLog e) + + setGitRemoteKey k = do + e <- ask + liftIO $ atomically $ writeTVar (gitRefLog e) (Just k) + +instance (MonadIO m) => HasStateDB (Git3 m) where + getStateDB = asks stateDb + +instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where + getStorage = do + e <- ask + case e of + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> pure peerStorage newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a } deriving newtype ( Applicative @@ -188,7 +259,7 @@ type Git3Perks m = ( MonadIO m instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where getClientAPI = do ask >>= \case - Git3Disconnected -> throwIO Git3PeerNotConnected + Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Connected{..} -> pure peerAPI instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where @@ -198,7 +269,17 @@ instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto ( getClientAPI = lift $ getClientAPI @api @proto nullGit3Env :: MonadIO m => m Git3Env -nullGit3Env = pure Git3Disconnected +nullGit3Env = Git3Disconnected <$> newTVarIO Nothing + +connectedDo :: (MonadIO m, MonadReader Git3Env m) => m a -> m a +connectedDo what = do + env <- ask + debug $ red "connectedDo" + case env of + Git3Disconnected{} -> do + throwIO Git3PeerNotConnected + + _ -> what withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a withGit3Env env a = runReaderT (fromGit3 a) env @@ -236,26 +317,36 @@ recover m = fix \again -> do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client - let connected = Git3Connected soname peerAPI + ref <- getGitRemoteKey >>= orThrowUser "remote ref not set" - liftIO $ withGit3Env connected again + dbPath <- getStatePathDB (AsBase58 ref) + + touch dbPath + db <- newDBPipeEnv dbPipeOptsDef dbPath + + let sto = AnyStorage (StorageClient storageAPI) + + connected <- Git3Connected db soname sto peerAPI <$> newTVarIO (Just ref) + + liftIO $ withGit3Env connected (evolveState >> again) + +gitReadCommitParents :: MonadIO m => ByteString -> m [GitHash] +gitReadCommitParents bs = do + what <- LBS8.lines bs + & takeWhile ( not . LBS8.null ) + & LBS8.unpack . LBS8.unlines + & parseTop + & orThrow (OtherGitError "invalid commit format") + + pure $ [ fromStringMay @GitHash hash + | ListVal [ StringLike "parent", StringLike hash ] <- what + ] & catMaybes 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) + parents <- gitReadObjectThrow Commit hhead >>= gitReadCommitParents skip <- if not (excludeParents opts) then do pure mempty @@ -328,8 +419,15 @@ unpackPEntry = \case ["T", s, h] -> (Tree,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h) _ -> Nothing +data ExportState = + ExportGetCommit + | ExportCheck + theDict :: forall m . ( HBS2GitPerks m , HasClientAPI PeerAPI UNIX m + , HasStorage m + , HasGitRemoteKey m + , MonadReader Git3Env m ) => Dict C m theDict = do makeDict @C do @@ -350,6 +448,23 @@ theDict = do for_ r $ \GitTreeEntry{..} -> do liftIO $ print $ pretty gitEntryHash <+> pretty gitEntryType <+> pretty gitEntrySize <+> pretty gitEntryName + + entry $ bindMatch "reflog" $ nil_ $ \case + [ SignPubKeyLike what ] -> do + debug $ "set reflog" <+> pretty (AsBase58 what) + lift $ setGitRemoteKey what + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "test:state:init" $ nil_ $ \case + [ ] -> do + lift $ connectedDo do + r <- getGitRemoteKey >>= orThrowUser "git remote not set" + p <- getStatePathDB (AsBase58 r) + debug $ "test:state:init" <+> pretty p + + _ -> throwIO (BadFormException @C nil) + entry $ bindMatch "test:git:tree:pack:dump" $ nil_ $ \case [ StringLike fn ] -> do @@ -376,8 +491,6 @@ theDict = do r <- callRpcWaitRetry @RpcPoke (TimeoutSec 0.5) 2 peer () >>= orThrowUser "hbs2-peer not found" notice $ pretty r - entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> flip runContT pure do - pure () entry $ bindMatch "test:git:tree:pack:write" $ nil_ $ \syn -> flip runContT pure do @@ -397,6 +510,124 @@ theDict = do liftIO $ gitWriteCommitPackIO o what $ \bs -> do BS.hPut to bs + entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> do + + r <- case syn of + [] -> gitRevParseThrow "HEAD" + [ StringLike co ] -> gitRevParseThrow co + _ -> throwIO (BadFormException @C nil) + + debug $ "process commit" <+> pretty r + + q <- newTVarIO ( HPSQ.empty @GitHash @Double @() ) + done <- newTVarIO ( mempty :: HashSet GitHash ) + + atomically $ modifyTVar q (HPSQ.insert r 1.0 ()) + + lift $ connectedDo do + + sto <- getStorage + + flip runContT pure do + + reader <- ContT $ withGitCat + + ContT $ bracket none $ const do + hClose $ getStdin reader + + flip fix ExportGetCommit $ \next -> \case + + ExportGetCommit -> do + + co' <- atomically $ stateTVar q $ HPSQ.alterMin \case + Nothing -> (Nothing, Nothing) + Just (k,p,v) -> (Just (k,p), Nothing) + + case co' of + Nothing -> next ExportCheck + + Just (co,prio) -> do + debug $ "Process commit" <+> pretty co + debug $ "check-pack-for" <+> pretty co + + already <- readTVarIO done <&> HS.member co + + if already + then next ExportGetCommit + else do + (t,bs) <- liftIO (gitReadObjectMaybe reader co) + >>= orThrow (GitReadError (show $ pretty co)) + + parents <- gitReadCommitParents bs + + for_ (zip [1..] parents) $ \(i,gh) -> do + atomically $ modifyTVar q (HPSQ.insert gh (prio-i) ()) + + atomically $ modifyTVar done (HS.insert co) + + next ExportGetCommit + + ExportCheck -> do + debug $ "ExportCheck dummy" <+> pretty r + debug "exit export" + + -- case co' of + -- Just co -> do + -- debug $ "Process commit" <+> pretty co + + -- parents <- gitReadObjectThrow Commit co >>= gitReadCommitParents + + -- debug $ pretty parents + + -- pure () + + + -- Nothing -> do + -- debug $ "check result for" <+> pretty r + + -- none + -- readTVarIO q <&> HPSQ.null + + -- when mt do + -- debug $ "check pack for" <+> pretty r + + -- делаем очередь коммитов + -- кладём коммит в очередь с приоритетом 1 + -- поехали мутить + -- + -- мутим: + -- + -- очередь пуста: + -- проверяем, для начального коммита есть пак? + -- есть -- возвращаем хэш, выходим + -- нет -- приплыли + -- + -- достали из очереди то, что наименьшим приоритетом + -- + -- смотрим, нет ли уже бандла + -- есть -> мутим + -- + -- нет -> делаем + -- взяли всех парентов + -- + -- если есть бандл для всех парента - мутим пак + -- как ^^^^^^^^^^^^^^^^^^^^^^^^^^ + -- + -- если нет - кладём в очередь с приоритетом меньше, чем у того, что + -- достали + -- + -- то, что достали кладём обратно (с большим приоритетом) + -- + -- пак: + -- + -- gitWriteCommitPackIO + -- + -- мутим + -- + -- + -- почему не рекурсия: она тут не хвостовая, а коммитов тысячи и миллионы (linux) + -- + -- debugPrefix :: LoggerEntry -> LoggerEntry debugPrefix = toStderr . logPrefix "[debug] " @@ -434,6 +665,7 @@ main = flip runContT pure do env <- nullGit3Env void $ lift $ withGit3Env env do + conf <- readLocalConf let dict = theDict - recover $ run dict cli + recover $ run dict (conf <> cli) diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index cf26f7cc..8fd86eef 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -49,6 +49,9 @@ common shared-properties , TupleSections , TypeApplications , TypeFamilies + , PatternSynonyms + , ViewPatterns + , RecordWildCards build-depends: @@ -109,11 +112,16 @@ library other-modules: exposed-modules: + HBS2.Git3.Types + HBS2.Git3.State.Types + HBS2.Git3.State.Direct + HBS2.Git3.Config.Local build-depends: base , base16-bytestring , binary , bzlib + , psqueues , unix hs-source-dirs: lib @@ -124,6 +132,21 @@ executable hbs2-git3 main-is: Main.hs -- other-modules: -- other-extensions: + build-depends: + base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git + , bzlib + , binary + , psqueues + , vector + + hs-source-dirs: app + default-language: GHC2021 + +executable hbs2-git-daemon + import: shared-properties + main-is: Daemon.hs + -- other-modules: + -- other-extensions: build-depends: base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git , bzlib @@ -134,3 +157,4 @@ executable hbs2-git3 default-language: GHC2021 + diff --git a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs new file mode 100644 index 00000000..539485fa --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs @@ -0,0 +1,30 @@ +module HBS2.Git3.Config.Local where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.System.Dir + +import HBS2.Git.Local.CLI + +import System.Directory + +import Data.Config.Suckless.Script + +import Data.Text.IO qualified as IO + +readLocalConf :: MonadIO m => m [Syntax C] +readLocalConf = do + + let name = ".hbs2-git3/config" + + g <- findGitDir + >>= orThrowUser ".git not found" + <&> ( name) . takeDirectory + + touch g + + liftIO (IO.readFile g) + <&> parseTop + >>= either (error.show) pure + + diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs new file mode 100644 index 00000000..8633a329 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs @@ -0,0 +1,51 @@ +module HBS2.Git3.State.Direct + ( module HBS2.Git3.State.Direct + , module HBS2.Git3.State.Types + ) where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.System.Dir + +import HBS2.Git3.State.Types + +import DBPipe.SQLite + +import System.Directory + +import Text.InterpolatedString.Perl6 (qc) + +unit :: FilePath +unit = "hbs2-git" + +getStatePath :: (MonadIO m, DBRef db) => db -> m FilePath +getStatePath p = do + dir <- liftIO $ getXdgDirectory XdgState unit + pure $ dir show (pretty p) + + +getStatePathDB :: (MonadIO m, DBRef db) => db -> m FilePath +getStatePathDB p = do + getStatePath p <&> ( "state.db") + + +withState :: (MonadIO m, HasStateDB m) => DBPipeM m a -> m a +withState action = getStateDB >>= flip withDB action + +evolveState :: (MonadIO m, HasStateDB m) => m () +evolveState = do + withState do + + ddl [qc| +create table if not exists +gitobject + ( githash text not null primary key + , type text not null + , cblock text not null + , pack text not null + ) +|] + + pure () + + diff --git a/hbs2-git3/lib/HBS2/Git3/State/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Types.hs new file mode 100644 index 00000000..a7fd1883 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State/Types.hs @@ -0,0 +1,16 @@ +module HBS2.Git3.State.Types + ( module HBS2.Git3.State.Types + , pattern SignPubKeyLike + ) where + + +import HBS2.Prelude.Plated +import HBS2.Net.Auth.Credentials + +import DBPipe.SQLite + +type DBRef w = ( Pretty w ) + +class MonadIO m => HasStateDB m where + getStateDB :: m DBPipeEnv + diff --git a/hbs2-git3/lib/HBS2/Git3/Types.hs b/hbs2-git3/lib/HBS2/Git3/Types.hs new file mode 100644 index 00000000..6af7c87e --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Types.hs @@ -0,0 +1,9 @@ +module HBS2.Git3.Types where + +import HBS2.Prelude.Plated +import HBS2.Net.Auth.Credentials + +type GitRemoteKey = PubKey 'Sign 'HBS2Basic + + +