mirror of https://github.com/voidlizard/hbs2
wip, git-remote-helper
This commit is contained in:
voidlizard
parent
2e0c0fc879
commit
eaadafd599
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue