diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 77d17e83..f8d694a3 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -1,3 +1,4 @@ +{-# Language RecordWildCards #-} module Main where import Prelude hiding (getLine) @@ -7,6 +8,8 @@ import HBS2.Git3.Run import HBS2.Git3.Config.Local import HBS2.Git3.State.Index import HBS2.Git3.Import +import HBS2.Git3.Export +import HBS2.Git3.Git import System.Posix.Signals import System.IO qualified as IO @@ -14,6 +17,7 @@ import System.Exit qualified as Exit import System.Environment (getArgs) import Text.InterpolatedString.Perl6 (qc) import Data.Text qualified as Text +import Data.Maybe import Data.Config.Suckless.Script @@ -68,14 +72,21 @@ data S = deriving stock (Eq,Ord,Show,Enum) +data DeferredOps = + DeferredOps + { exportQ :: TQueue (GitRef, Maybe GitHash) + } + localDict :: forall m . ( HBS2GitPerks m -- , HasClientAPI PeerAPI UNIX m -- , HasStorage m -- , HasGitRemoteKey m -- , HasStateDB m - ) => Dict C (Git3 m) -localDict = makeDict @C do + ) + => DeferredOps -> Dict C (Git3 m) + +localDict DeferredOps{..} = makeDict @C do entry $ bindMatch "r:capabilities" $ nil_ $ \syn -> do sendLine "push" sendLine "fetch" @@ -93,7 +104,17 @@ localDict = makeDict @C do sendLine "" entry $ bindMatch "r:push" $ nil_ $ splitPushArgs $ \pushFrom pushTo -> lift do + r0 <- for pushFrom gitRevParseThrow + notice $ pretty $ [qc|ok {pretty pushTo}|] + + case (r0, pushTo) of + (Nothing, ref) -> do + export Nothing [(ref, nullHash)] + + (Just h, ref)-> do + export (Just h) [(ref, h)] + sendLine [qc|ok {pretty pushTo}|] entry $ bindMatch "r:" $ nil_ $ \syn -> lift do @@ -127,7 +148,9 @@ main = flip runContT pure do lift $ void $ installHandler sigPIPE Ignore Nothing env <- nullGit3Env - let dict = theDict <> localDict + ops <- DeferredOps <$> newTQueueIO + + let dict = theDict <> localDict ops void $ lift $ withGit3Env env do diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 3137a8df..f54ce68a 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -1,110 +1,27 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language MultiWayIf #-} -{-# Language FunctionalDependencies #-} -{-# Language ViewPatterns #-} -{-# Language PatternSynonyms #-} -{-# Language RecordWildCards #-} -{-# Language UndecidableInstances #-} -{-# Language AllowAmbiguousTypes #-} -{-# Language OverloadedLabels #-} module Main where import HBS2.Git3.Prelude -import HBS2.Git3.State.Index -import HBS2.Git3.Git.Pack import HBS2.Git3.Run -import HBS2.Peer.CLI.Detect -import HBS2.Peer.RPC.API.LWWRef -import HBS2.Peer.RPC.API.Storage -import HBS2.Peer.RPC.Client.StorageClient -import HBS2.Storage.Operations.Missed - --- move to Data.Config.Suckless.Script.Filea sepatate library import HBS2.Data.Log.Structured -import HBS2.CLI.Run.Internal.Merkle (getTreeContents) -import HBS2.CLI.Run.RefLog (getCredentialsForReflog,mkRefLogUpdateFrom) - -import HBS2.System.Dir - -import HBS2.Git3.Types import HBS2.Git3.Config.Local -import HBS2.Git3.Git -import HBS2.Git3.Export -import HBS2.Git3.Import -import HBS2.Git3.State.RefLog import Data.Config.Suckless.Script -import Data.Config.Suckless.Script.File -import Codec.Compression.Zstd.Streaming qualified as ZstdS -import Codec.Compression.Zstd.Streaming (Result(..)) -import Codec.Compression.Zstd.Lazy qualified as ZstdL - -import Codec.Compression.Zlib qualified as Zlib - -import Data.HashPSQ qualified as HPSQ -import Data.HashPSQ (HashPSQ) - -import Data.Maybe -import Data.List qualified as L -import Data.List (sortBy) -import Data.List.Split (chunksOf) -import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Lazy qualified as LBS -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BS8 -import Data.ByteString.Lazy ( ByteString ) -import Data.ByteString.Builder as Builder import Network.ByteOrder qualified as N -import Text.InterpolatedString.Perl6 (qc) -import Data.Set qualified as Set import Data.HashSet qualified as HS import Data.HashSet (HashSet(..)) -import Data.HashMap.Strict qualified as HM -import Data.HashMap.Strict (HashMap(..)) -import Data.Word -import Data.Fixed -import Data.Either -import Data.Ord (comparing) -import Data.Generics.Labels -import Data.Generics.Product -import Lens.Micro.Platform - 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.State qualified as State -import Control.Monad.Trans.Writer.CPS qualified as Writer -import Control.Concurrent.STM qualified as STM -import System.Directory (setCurrentDirectory) -import System.Random hiding (next) -import System.IO.MMap (mmapFileByteString) -import System.IO qualified as IO -import System.IO (hPrint,hPutStrLn,hPutStr) -import System.IO.Temp as Temp -import System.TimeIt - -import Data.Vector qualified as Vector -import Data.Vector.Algorithms.Search qualified as MV - -import UnliftIO.Concurrent -import UnliftIO.IO.File qualified as UIO - -import Control.Monad.ST -import Data.BloomFilter qualified as Bloom -import Data.BloomFilter.Mutable qualified as MBloom - import Crypto.Hash qualified as C {- HLINT ignore "Functor law" -} {- HLINT ignore "Eta reduce" -} - - readIndexFromFile :: forall m . MonadIO m => FilePath -> m (HashSet GitHash) diff --git a/hbs2-git3/lib/HBS2/Git3/Export.hs b/hbs2-git3/lib/HBS2/Git3/Export.hs index 2307eecc..42fd2188 100644 --- a/hbs2-git3/lib/HBS2/Git3/Export.hs +++ b/hbs2-git3/lib/HBS2/Git3/Export.hs @@ -1,7 +1,7 @@ {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} -module HBS2.Git3.Export (exportEntries) where +module HBS2.Git3.Export (exportEntries,export) where import HBS2.Git3.Prelude import HBS2.Git3.State.Index @@ -55,35 +55,32 @@ data ECC = | ECCFinalize Int Bool FilePath Handle Result -export :: forall m . HBS2GitPerks m => Git3 m () -export = do - none - exportEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) () exportEntries prefix = do - entry $ bindMatch (prefix <> "export") $ nil_ $ \syn -> lift $ connectedDo do - let (opts, argz) = splitOpts [("--dry",0),("--ref",1),("--set",2),("--del",1)] syn + entry $ bindMatch (prefix <> "export") $ nil_ $ \syn -> lift $ connectedDo do + let (opts, argz) = splitOpts [("--ref",1),("--set",2),("--del",1)] syn - let dry = or [ True | ListVal [StringLike "--dry"] <- opts ] + let hd = headDef "HEAD" [ x | StringLike x <- argz] + h <- gitRevParseThrow hd - let hd = headDef "HEAD" [ x | StringLike x <- argz] - h <- gitRevParseThrow hd + refs' <- S.toList_ $ for opts $ \case + ListVal [StringLike "--ref", StringLike x] -> do + S.yield (gitNormaliseRef (fromString x), h) - refs' <- S.toList_ $ for opts $ \case - ListVal [StringLike "--ref", StringLike x] -> do - S.yield (gitNormaliseRef (fromString x), h) + ListVal [StringLike "--set", StringLike x, StringLike what] -> do + y <- gitRevParseThrow what + S.yield $ (gitNormaliseRef (fromString x), y) - ListVal [StringLike "--set", StringLike x, StringLike what] -> do - y <- gitRevParseThrow what - S.yield $ (gitNormaliseRef (fromString x), y) + ListVal [StringLike "--del", StringLike x] -> do + S.yield $ (gitNormaliseRef (fromString x), GitHash (BS.replicate 20 0)) - ListVal [StringLike "--del", StringLike x] -> do - S.yield $ (gitNormaliseRef (fromString x), GitHash (BS.replicate 20 0)) + _ -> none - _ -> none - - let refs = HM.toList $ HM.fromList refs' + let refs = HM.toList $ HM.fromList refs' + export (Just h) refs +export :: forall m . HBS2GitPerks m => Maybe GitHash -> [(GitRef, GitHash)] -> Git3 m () +export mbh refs = do tn <- getNumCapabilities updateReflogIndex @@ -106,7 +103,8 @@ exportEntries prefix = do already <- readTVarIO _already <&> HS.member x pure (not already) -- && not alsoInIdx) - hpsq <- readCommitChainHPSQ notWrittenYet Nothing h (\c -> debug $ "commit" <+> pretty c) + hpsq <- maybe1 mbh (pure HPSQ.empty) $ \h -> do + readCommitChainHPSQ notWrittenYet Nothing h (\c -> debug $ "commit" <+> pretty c) txCheckQ <- newTVarIO ( mempty :: HashSet HashRef ) @@ -144,7 +142,7 @@ exportEntries prefix = do exported <- readTVarIO _exported debug $ red "EXPORTED" <+> pretty exported - when (not dry && exported > 0) do + when (exported > 0) do href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO writeLogEntry ("tree" <+> pretty ts <+> pretty href) debug $ "SENDING" <+> pretty href <+> pretty fn @@ -177,7 +175,7 @@ exportEntries prefix = do -- void $ ContT $ bracket (pure pool) cancel - let lastCommit = lastDef h r + let lastCommit = lastMay r workers <- lift $ forM (zip [0..] commitz) $ \(i,chunk) -> async $ flip runContT pure do @@ -213,7 +211,7 @@ exportEntries prefix = do atomically do writeTBQueue sourceQ (Just e) - when (commit == lastCommit) do + when (Just commit == lastCommit) do writeRefSectionSome sourceQ refs t0 <- getTimeCoarse @@ -299,26 +297,6 @@ exportEntries prefix = do atomically do writeTBQueue sourceQ (Just e) - -- writeRefSection sourceQ commit refs = do - - -- ts <- liftIO $ getPOSIXTime <&> round - - -- let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty x) - -- | x <- refs - -- ] & LBS8.unlines - - -- let sha1 = gitHashBlobPure brefs - - -- -- debug $ green "THIS IS THE LAST COMMIT BLOCK" <+> pretty commit <+> "ADDING REF INFO" <+> pretty sha1 - - -- let e = [ Builder.byteString (coerce sha1) - -- , Builder.char8 'R' - -- , Builder.lazyByteString brefs - -- ] & Builder.toLazyByteString . mconcat - - -- atomically do - -- writeTBQueue sourceQ (Just e) - segmentWriter env bytes_ sourceQ hbs2Q = flip runReaderT env do maxW <- getPackedSegmetSize level <- getCompressionLevel @@ -352,7 +330,7 @@ exportEntries prefix = do void $ writeCompressedChunkZstd (write bytes_ fh) sn Nothing hClose fh atomically $ writeTBQueue hbs2Q (Just (fn, bnum)) - notice $ "SEGMENT" <+> pretty bnum <+> pretty fn + debug $ "SEGMENT" <+> pretty bnum <+> pretty fn when again $ loop ECCInit atomically $ writeTBQueue hbs2Q Nothing diff --git a/hbs2-git3/lib/HBS2/Git3/Git.hs b/hbs2-git3/lib/HBS2/Git3/Git.hs index 9ae716f6..ddb78282 100644 --- a/hbs2-git3/lib/HBS2/Git3/Git.hs +++ b/hbs2-git3/lib/HBS2/Git3/Git.hs @@ -42,8 +42,9 @@ import UnliftIO pattern GitHashLike:: forall {c} . GitHash -> Syntax c pattern GitHashLike x <- ( \case - StringLike s -> fromStringMay @GitHash s - _ -> Nothing + StringLike s -> fromStringMay @GitHash s + LitIntVal 0 -> Just $ GitHash (BS.replicate 20 0) + _ -> Nothing -> Just x ) data GitException = diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index c228131a..e39fd22b 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -398,6 +398,9 @@ importedCheckpoint = do toMPlus (fromStringMay @HashRef f) +nullHash :: GitHash +nullHash = GitHash (BS.replicate 20 0) + {- HLINT ignore "Functor law"-} importedRefs :: forall m . ( Git3Perks m , MonadReader Git3Env m @@ -427,8 +430,10 @@ importedRefs = do , GitHashLike g , StringLike n ] <- refs , HS.member th txh - ] & HM.fromListWith (\(a,t1) (b,t2) -> if t1 > t2 then (a,t1) else (b,t2)) + ] & L.sortOn ( snd . snd ) + & HM.fromList & fmap fst . HM.elems + & filter ( (/= nullHash) . snd ) pure rrefs