wip, git-remote-helper

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
 

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)

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
+  entry $ bindMatch (prefix <> "export") $ nil_ $ \syn -> lift $ connectedDo do
-      let (opts, argz) = splitOpts [("--dry",0),("--ref",1),("--set",2),("--del",1)] syn
+    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]
+    refs' <- S.toList_ $ for opts $ \case
-      h <- gitRevParseThrow hd
+              ListVal [StringLike "--ref", StringLike x] -> do
+                S.yield (gitNormaliseRef (fromString x), h)
 
-      refs' <- S.toList_ $ for opts $ \case
+              ListVal [StringLike "--set", StringLike x, StringLike what] -> do
-                ListVal [StringLike "--ref", StringLike x] -> do
+                y <- gitRevParseThrow what
-                  S.yield (gitNormaliseRef (fromString x), h)
+                S.yield $ (gitNormaliseRef (fromString x), y)
 
-                ListVal [StringLike "--set", StringLike x, StringLike what] -> do
+              ListVal [StringLike "--del", StringLike x] -> do
-                  y <- gitRevParseThrow what
+                S.yield $ (gitNormaliseRef (fromString x), GitHash (BS.replicate 20 0))
-                  S.yield $ (gitNormaliseRef (fromString x), y)
 
-                ListVal [StringLike "--del", StringLike x] -> do
+              _ -> none
-                  S.yield $ (gitNormaliseRef (fromString x), GitHash (BS.replicate 20 0))
 
-                _ -> none
+    let refs = HM.toList $ HM.fromList refs'
-
+    export (Just h) refs
-      let refs = HM.toList $ HM.fromList 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
 

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
+    StringLike s  -> fromStringMay @GitHash s
-    _                -> Nothing
+    LitIntVal 0   -> Just $ GitHash (BS.replicate 20 0)
+    _             -> Nothing
       -> Just x )
 
 data GitException =

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