mirror of https://github.com/voidlizard/hbs2
some documentation and minor refactoring
This commit is contained in:
voidlizard
parent
74659bffc6
commit
ca033d2c1c
|
|
@ -230,6 +230,8 @@ main = flip runContT pure do
|
|||
|
||||
setupLogger
|
||||
|
||||
setStatusOn
|
||||
|
||||
env <- nullGit3Env
|
||||
|
||||
ops <- DeferredOps <$> newTQueueIO
|
||||
|
|
|
|||
|
|
@ -1,10 +1,15 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Git3.Logger ( setupLogger
|
||||
, flushLoggers
|
||||
, silence
|
||||
, debugPrefix
|
||||
, status, setStatusOn, STATUS
|
||||
) where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Prelude
|
||||
import HBS2.System.Logger.Simple.ANSI as Logger
|
||||
|
||||
data STATUS
|
||||
|
||||
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
||||
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
||||
|
|
@ -31,4 +36,14 @@ silence = do
|
|||
setLoggingOff @NOTICE
|
||||
setLoggingOff @INFO
|
||||
|
||||
instance HasLogLevel STATUS where
|
||||
type instance LogLevel STATUS = 10
|
||||
|
||||
status :: forall a m . (MonadIO m) => Doc a -> m ()
|
||||
status = Logger.writeLog @STATUS . show
|
||||
|
||||
setStatusOn :: MonadIO m => m ()
|
||||
setStatusOn = do
|
||||
setLogging @STATUS $ toStderr . logPrefix ""
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -51,3 +51,21 @@ hbs2-git3 repo:remotes
|
|||
|
||||
|]
|
||||
|
||||
manGitListObjectsNew :: MakeDictM c m () -> MakeDictM c m ()
|
||||
manGitListObjectsNew =
|
||||
brief "lists new git objects"
|
||||
. args [ arg "hash|name" "remote"
|
||||
, arg "(-r rev)?" "git revision"
|
||||
]
|
||||
|
||||
manRepoRelayOnly :: MakeDictM c m () -> MakeDictM c m ()
|
||||
manRepoRelayOnly = brief "subscribe hbs2-peer to repository references (lwwref+reflog)"
|
||||
. desc description
|
||||
. args [ arg "public-key" "lwwref"]
|
||||
|
||||
where
|
||||
description = vcat [
|
||||
"useful when you want hbs2-peer to distribute and backup"
|
||||
<> "the repository data without git fetching/cloning"
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ import HBS2.Storage.Operations.Class as Exported
|
|||
import HBS2.System.Logger.Simple.ANSI as Exported
|
||||
|
||||
import HBS2.Git3.Types as Exported
|
||||
import HBS2.Git3.Logger as Exported
|
||||
-- import HBS2.Git3.State.Types as Exported
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
|
|
|||
|
|
@ -56,8 +56,16 @@ listRemotes = do
|
|||
|
||||
pure urls
|
||||
|
||||
resolveRepoKeyThrow :: MonadIO m => [Syntax C] -> m GitRepoKey
|
||||
resolveRepoKeyThrow = \case
|
||||
resolveRepo :: forall c m . (IsContext c, HBS2GitPerks m) => [Syntax c] -> Git3 m ()
|
||||
resolveRepo syn = do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
|
||||
resolved :: forall c m . (IsContext c, HBS2GitPerks m) => [Syntax c] -> Git3 m ()
|
||||
resolved = resolveRepo
|
||||
|
||||
resolveRepoKeyThrow :: forall c m . (IsContext c, MonadIO m) => [Syntax c] -> m GitRepoKey
|
||||
resolveRepoKeyThrow s = case maybeToList (headMay s) of
|
||||
[ SignPubKeyLike url ] -> pure url
|
||||
[ RepoURL url ] -> pure url
|
||||
[ StringLike x ] -> do
|
||||
|
|
|
|||
|
|
@ -7,16 +7,16 @@ import Data.Config.Suckless.Script
|
|||
import Data.HashSet qualified as HS
|
||||
import Data.Text qualified as Text
|
||||
|
||||
pattern RepoURL :: GitRemoteKey -> Syntax C
|
||||
pattern RepoURL :: forall {c} . IsContext c => GitRemoteKey -> Syntax c
|
||||
pattern RepoURL x <- (isRepoURL [ "hbs2", "hbs23" ] -> Just x)
|
||||
|
||||
pattern RepoURL3 :: GitRemoteKey -> Syntax C
|
||||
pattern RepoURL3 :: forall {c} . IsContext c => GitRemoteKey -> Syntax c
|
||||
pattern RepoURL3 x <- (isRepoURL [ "hbs23" ] -> Just x)
|
||||
|
||||
remoteRepoURL :: GitRemoteKey -> Text
|
||||
remoteRepoURL k = Text.pack $ show $ "hbs23://" <> pretty (AsBase58 k)
|
||||
|
||||
isRepoURL :: [Text] -> Syntax C -> Maybe GitRemoteKey
|
||||
isRepoURL :: forall c . IsContext c => [Text] -> Syntax c -> Maybe GitRemoteKey
|
||||
isRepoURL pref = \case
|
||||
TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of
|
||||
ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk
|
||||
|
|
|
|||
|
|
@ -96,31 +96,36 @@ compression ; prints compression level
|
|||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "segment" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> lift do
|
||||
setPackedSegmedSize (fromIntegral n)
|
||||
brief "sets packed segment size in bytes"
|
||||
$ entry $ bindMatch "segment" $ nil_ $ \case
|
||||
[ LitIntVal n ] -> lift do
|
||||
setPackedSegmedSize (fromIntegral n)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "quiet" $ nil_ $ const $ lift do
|
||||
silence
|
||||
brief "silent mode"
|
||||
$ entry $ bindMatch "quiet" $ nil_ $ const $ lift do
|
||||
silence
|
||||
|
||||
entry $ bindMatch "index-block-size" $ nil_ \case
|
||||
hidden $
|
||||
entry $ bindMatch "index-block-size" $ nil_ \case
|
||||
[ LitIntVal size ]-> lift do
|
||||
setIndexBlockSize (fromIntegral size)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "git:tree:ls" $ nil_ $ const do
|
||||
brief "list current git objects"
|
||||
$ entry $ bindMatch "git:tree:ls" $ nil_ $ const do
|
||||
r <- gitReadTree "HEAD"
|
||||
for_ r $ \GitTreeEntry{..} -> do
|
||||
liftIO $ print $ pretty gitEntryHash
|
||||
liftIO $ print $ fill 40 (pretty gitEntryHash)
|
||||
<+> pretty gitEntryType
|
||||
<+> pretty gitEntrySize
|
||||
<+> pretty gitEntryName
|
||||
|
||||
entry $ bindMatch "debug" $ nil_ $ const do
|
||||
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||||
brief "turn debug output on"
|
||||
$ entry $ bindMatch "debug" $ nil_ $ const do
|
||||
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||||
|
||||
-- hidden do
|
||||
|
||||
|
|
@ -176,25 +181,26 @@ compression ; prints compression level
|
|||
liftIO $ print $ "object" <+> pretty h <+> pretty s
|
||||
|
||||
|
||||
entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
hidden $
|
||||
entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
let (_, argz) = splitOpts [] syn
|
||||
let (_, argz) = splitOpts [] syn
|
||||
|
||||
hash <- case argz of
|
||||
[ x@StringLike{}, GitHashLike h ] -> do
|
||||
resolveRepoKeyThrow [x] >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
pure h
|
||||
hash <- case argz of
|
||||
[ x@StringLike{}, GitHashLike h ] -> do
|
||||
resolveRepoKeyThrow [x] >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
pure h
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
idx <- openIndex
|
||||
idx <- openIndex
|
||||
|
||||
answ <- indexEntryLookup idx hash
|
||||
answ <- indexEntryLookup idx hash
|
||||
|
||||
for_ answ $ \bs -> do
|
||||
let a = coerce (BS.take 32 bs) :: HashRef
|
||||
liftIO $ print $ pretty a
|
||||
for_ answ $ \bs -> do
|
||||
let a = coerce (BS.take 32 bs) :: HashRef
|
||||
liftIO $ print $ pretty a
|
||||
|
||||
entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do
|
||||
sto <- getStorage
|
||||
|
|
@ -218,24 +224,30 @@ compression ; prints compression level
|
|||
for_ trees $ \tree -> do
|
||||
writeAsGitPack dir tree
|
||||
|
||||
entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift $ connectedDo do
|
||||
idx <- openIndex
|
||||
num_ <- newIORef 0
|
||||
enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x))
|
||||
readIORef num_ >>= liftIO . print . pretty
|
||||
brief "prints indexed object count for repo" $
|
||||
entry $ bindMatch "repo:index:count" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift $ connectedDo do
|
||||
files <- listObjectIndexFiles
|
||||
for_ files $ \(ifn,_) -> do
|
||||
lbs <- liftIO $ LBS.readFile ifn
|
||||
resolveRepo syn
|
||||
|
||||
void $ runConsumeLBS lbs $ readSections $ \s ss -> do
|
||||
idx <- openIndex
|
||||
num_ <- newIORef 0
|
||||
enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x))
|
||||
readIORef num_ >>= liftIO . print . pretty
|
||||
|
||||
let (sha1, blake) = LBS.splitAt 20 ss
|
||||
& over _1 (coerce @_ @GitHash . LBS.toStrict)
|
||||
& over _2 (coerce @_ @HashRef . LBS.toStrict)
|
||||
brief "lists indexed objects for repo" $
|
||||
entry $ bindMatch "repo:index:list" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
files <- listObjectIndexFiles
|
||||
for_ files $ \(ifn,_) -> do
|
||||
lbs <- liftIO $ LBS.readFile ifn
|
||||
|
||||
liftIO $ hPrint stdout $ pretty sha1 <+> pretty blake
|
||||
void $ runConsumeLBS lbs $ readSections $ \s ss -> do
|
||||
|
||||
let (sha1, blake) = LBS.splitAt 20 ss
|
||||
& over _1 (coerce @_ @GitHash . LBS.toStrict)
|
||||
& over _2 (coerce @_ @HashRef . LBS.toStrict)
|
||||
|
||||
liftIO $ hPrint stdout $ pretty sha1 <+> pretty blake
|
||||
|
||||
entry $ bindMatch "reflog:index:check" $ nil_ $ \case
|
||||
[ StringLike fn ] -> lift do
|
||||
|
|
@ -246,24 +258,26 @@ compression ; prints compression level
|
|||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift $ connectedDo do
|
||||
entry $ bindMatch "repo:index:compact" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
size <- getIndexBlockSize
|
||||
compactIndex size
|
||||
|
||||
entry $ bindMatch "reflog:index:path" $ nil_ $ const $ lift $ connectedDo do
|
||||
entry $ bindMatch "repo:index:path" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
indexPath >>= liftIO . print . pretty
|
||||
|
||||
-- let entriesListOf lbs = S.toList_ $ runConsumeLBS lbs $ readSections $ \s ss -> do
|
||||
entry $ bindMatch "reflog:index:files" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
entry $ bindMatch "repo:index:files" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
files <- listObjectIndexFiles
|
||||
cur <- pwd
|
||||
for_ files $ \(f',s) -> do
|
||||
let f = makeRelative cur f'
|
||||
liftIO $ print $ fill 10 (pretty s) <+> pretty f
|
||||
|
||||
entry $ bindMatch "reflog:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
entry $ bindMatch "repo:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
r <- newIORef ( mempty :: HashSet HashRef )
|
||||
index <- openIndex
|
||||
enumEntries index $ \bs -> do
|
||||
|
|
@ -275,9 +289,8 @@ compression ; prints compression level
|
|||
for_ z $ \h ->do
|
||||
liftIO $ print $ pretty h
|
||||
|
||||
entry $ bindMatch "reflog:index:build" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
entry $ bindMatch "repo:index:build" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
updateReflogIndex
|
||||
|
||||
entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case
|
||||
|
|
@ -289,7 +302,9 @@ compression ; prints compression level
|
|||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "git:commit:list:objects:new" $ nil_ $ \case
|
||||
[ StringLike what ] -> lift $ connectedDo do
|
||||
[ repo, StringLike what ] -> lift $ connectedDo do
|
||||
|
||||
resolveRepo [repo]
|
||||
|
||||
commit <- gitRevParseThrow what
|
||||
|
||||
|
|
@ -323,59 +338,63 @@ compression ; prints compression level
|
|||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
let (opts,argz) = splitOpts [] syn
|
||||
manGitListObjectsNew $
|
||||
entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
let what = headDef "HEAD" [ x | StringLike x <- argz ]
|
||||
resolveRepo syn
|
||||
|
||||
h0 <- gitRevParseThrow what
|
||||
let (opts,argz) = splitOpts [("-r", 1)] (tail syn)
|
||||
|
||||
no_ <- newTVarIO 0
|
||||
let what = headDef "HEAD" [ x | MatchOption "-r" (StringLike x) <- opts ]
|
||||
|
||||
void $ flip runContT pure do
|
||||
h0 <- gitRevParseThrow what
|
||||
|
||||
lift updateReflogIndex
|
||||
no_ <- newTVarIO 0
|
||||
|
||||
idx <- lift openIndex
|
||||
let req h = lift $ indexEntryLookup idx h <&> isNothing
|
||||
void $ flip runContT pure do
|
||||
|
||||
(t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle)
|
||||
lift updateReflogIndex
|
||||
|
||||
let s = HPSQ.size r
|
||||
debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1)
|
||||
idx <- lift openIndex
|
||||
let req h = lift $ indexEntryLookup idx h <&> isNothing
|
||||
|
||||
cap <- liftIO getNumCapabilities
|
||||
gitCatBatchQ <- contWorkerPool cap do
|
||||
che <- ContT withGitCat
|
||||
pure $ gitReadObjectMaybe che
|
||||
(t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle)
|
||||
|
||||
uniq_ <- newTVarIO mempty
|
||||
-- c1 <- newCacheFixedHPSQ 1000
|
||||
(t3, _) <- timeItT $ lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do
|
||||
let s = HPSQ.size r
|
||||
debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1)
|
||||
|
||||
(_,self) <- gitCatBatchQ commit
|
||||
>>= orThrow (GitReadError (show $ pretty commit))
|
||||
cap <- liftIO getNumCapabilities
|
||||
gitCatBatchQ <- contWorkerPool cap do
|
||||
che <- ContT withGitCat
|
||||
pure $ gitReadObjectMaybe che
|
||||
|
||||
tree <- gitReadCommitTree self
|
||||
uniq_ <- newTVarIO mempty
|
||||
-- c1 <- newCacheFixedHPSQ 1000
|
||||
(t3, _) <- timeItT $ lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do
|
||||
|
||||
-- читаем только те объекты, которые не в индексе
|
||||
gitReadTreeObjectsOnly commit
|
||||
<&> ([commit,tree]<>)
|
||||
>>= \hs -> atomically (for_ hs (modifyTVar uniq_ . HS.insert))
|
||||
(_,self) <- gitCatBatchQ commit
|
||||
>>= orThrow (GitReadError (show $ pretty commit))
|
||||
|
||||
debug $ "read new objects" <+> pretty (realToFrac @_ @(Fixed E2) t3)
|
||||
tree <- gitReadCommitTree self
|
||||
|
||||
(t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjects idx
|
||||
-- читаем только те объекты, которые не в индексе
|
||||
gitReadTreeObjectsOnly commit
|
||||
<&> ([commit,tree]<>)
|
||||
>>= \hs -> atomically (for_ hs (modifyTVar uniq_ . HS.insert))
|
||||
|
||||
liftIO $ for_ new $ \n -> do
|
||||
print $ pretty n
|
||||
-- notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4)
|
||||
debug $ "read new objects" <+> pretty (realToFrac @_ @(Fixed E2) t3)
|
||||
|
||||
(t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjects idx
|
||||
|
||||
liftIO $ for_ new $ \n -> do
|
||||
print $ pretty n
|
||||
-- notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4)
|
||||
|
||||
|
||||
entry $ bindMatch "reflog:tx:list:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
txImported >>= liftIO . print . vcat . (fmap pretty) . HS.toList
|
||||
entry $ bindMatch "repo:tx:list:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
|
||||
txImported >>= liftIO . print . vcat . fmap pretty . HS.toList
|
||||
|
||||
let (opts, argz) = splitOpts [ ("--checkpoints",0)
|
||||
, ("--segments",0)
|
||||
|
|
@ -402,18 +421,17 @@ compression ; prints compression level
|
|||
forM_ decoded print
|
||||
|
||||
|
||||
entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
entry $ bindMatch "repo:tx:list" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
resolveRepo syn
|
||||
|
||||
let (opts, argz) = splitOpts [ ("--checkpoints",0)
|
||||
, ("--segments",0)
|
||||
] syn
|
||||
, ("--segments",0)
|
||||
] syn
|
||||
|
||||
let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ]
|
||||
let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ]
|
||||
|
||||
resolveRepoKeyThrow argz >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
|
||||
hxs <- txListAll Nothing
|
||||
|
||||
liftIO $ forM_ hxs $ \(h,tx) -> do
|
||||
|
|
@ -428,65 +446,55 @@ compression ; prints compression level
|
|||
|
||||
forM_ decoded print
|
||||
|
||||
entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
entry $ bindMatch "repo:refs" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
resolveRepo syn
|
||||
|
||||
rrefs <- importedRefs
|
||||
for_ rrefs $ \(r,h) -> do
|
||||
liftIO $ print $ fill 20 (pretty h) <+> pretty r
|
||||
|
||||
entry $ bindMatch "reflog:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
|
||||
entry $ bindMatch "repo:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty)
|
||||
|
||||
entry $ bindMatch "repo:wait" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
|
||||
resolveRepo syn
|
||||
getRepoManifest >>= liftIO . print . pretty . mkForm "manifest" . coerce
|
||||
|
||||
manRemotes $ entry $ bindAlias "remotes" "repo:remotes"
|
||||
|
||||
hidden $
|
||||
manRemotes $
|
||||
entry $ bindMatch "repo:remotes" $ nil_ $ const $ lift do
|
||||
remotes <- listRemotes
|
||||
liftIO $ for_ remotes $ \(r,k) -> do
|
||||
print $ fill 44 (pretty (AsBase58 k)) <+> pretty r
|
||||
manRemotes $
|
||||
entry $ bindMatch "repo:remotes" $ nil_ $ const $ lift do
|
||||
remotes <- listRemotes
|
||||
liftIO $ for_ remotes $ \(r,k) -> do
|
||||
print $ fill 44 (pretty (AsBase58 k)) <+> pretty r
|
||||
|
||||
entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
entry $ bindMatch "repo:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
p <- importedCheckpoint
|
||||
liftIO $ print $ pretty p
|
||||
|
||||
entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
importGitRefLog
|
||||
hidden do
|
||||
entry $ bindMatch "repo:import" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
importGitRefLog
|
||||
|
||||
brief "shows repo manifest" $
|
||||
entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
resolveRepo syn
|
||||
manifest <- Repo.getRepoManifest
|
||||
liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest)
|
||||
|
||||
brief "shows repo reflog" $
|
||||
entry $ bindMatch "repo:reflog" $ nil_ $ const $ lift $ connectedDo do
|
||||
entry $ bindMatch "repo:reflog" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
resolveRepo syn
|
||||
repo <- Repo.getRepoManifest
|
||||
|
||||
reflog <- getRefLog repo & orThrow GitRepoManifestMalformed
|
||||
|
||||
liftIO $ print $ pretty (AsBase58 reflog)
|
||||
|
||||
entry $ bindMatch "repo:credentials" $ nil_ $ \syn -> lift $ connectedDo $ do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo (Just 10) =<< getGitRepoKeyThrow
|
||||
|
||||
resolveRepo syn
|
||||
(p,_) <- getRepoRefLogCredentials
|
||||
liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )]
|
||||
|
||||
|
|
@ -525,25 +533,21 @@ compression ; prints compression level
|
|||
|
||||
-- FIXME: maybe-add-default-remote
|
||||
entry $ bindMatch "repo:head" $ nil_ $ \syn -> lift $ connectedDo $ do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
resolveRepo syn
|
||||
lww <- getRepoRefMaybe
|
||||
liftIO $ print $ pretty lww
|
||||
|
||||
entry $ bindMatch "repo:gk:journal:import" $ nil_ $ \syn -> lift $ connectedDo $ do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
resolveRepo syn
|
||||
importGroupKeys
|
||||
|
||||
entry $ bindMatch "repo:gk:journal:imported" $ nil_ $ \syn -> lift $ connectedDo $ do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
resolveRepo syn
|
||||
readGroupKeyFile <&> maybe nil (mkSym @C . show . pretty)
|
||||
>>= liftIO . print . pretty
|
||||
|
||||
entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do
|
||||
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
resolveRepo syn
|
||||
|
||||
ref <- getGitRepoKeyThrow
|
||||
|
||||
|
|
@ -573,12 +577,13 @@ compression ; prints compression level
|
|||
manInit $ entry $
|
||||
bindAlias "init" "repo:init"
|
||||
|
||||
entry $ bindMatch "repo:relay-only" $ nil_ $ \case
|
||||
[ SignPubKeyLike repo ] -> lift $ connectedDo do
|
||||
setGitRepoKey repo
|
||||
waitRepo (Just 10) =<< getGitRepoKeyThrow
|
||||
manRepoRelayOnly $
|
||||
entry $ bindMatch "repo:relay-only" $ nil_ $ \case
|
||||
[ SignPubKeyLike repo ] -> lift $ connectedDo do
|
||||
setGitRepoKey repo
|
||||
waitRepo (Just 10) =<< getGitRepoKeyThrow
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
exportEntries "reflog:"
|
||||
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ import Codec.Compression.Zstd (maxCLevel)
|
|||
|
||||
newtype RepoManifest = RepoManifest [Syntax C]
|
||||
|
||||
|
||||
-- FIXME: cache
|
||||
getGK :: forall m . HBS2GitPerks m => Git3 m (Maybe (HashRef, GroupKey 'Symm 'HBS2Basic))
|
||||
getGK = do
|
||||
|
|
@ -64,7 +65,7 @@ getRefLog mf = lastMay [ x
|
|||
updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m ()
|
||||
updateRepoKey key = do
|
||||
|
||||
notice $ "updateRepoKey" <+> pretty (AsBase58 key)
|
||||
status $ "updateRepoKey" <+> pretty (AsBase58 key)
|
||||
|
||||
setGitRepoKey key
|
||||
|
||||
|
|
@ -72,7 +73,7 @@ updateRepoKey key = do
|
|||
|
||||
ask >>= \case
|
||||
Git3Connected{..} -> do
|
||||
notice $ yellow "UPDATED REFLOG" <+> pretty (fmap AsBase58 reflog)
|
||||
debug $ yellow "UPDATED REFLOG" <+> pretty (fmap AsBase58 reflog)
|
||||
atomically $ writeTVar gitRefLog reflog
|
||||
|
||||
_ -> none
|
||||
|
|
@ -241,7 +242,7 @@ waitRepo :: forall m . HBS2GitPerks m
|
|||
-> Git3 m ()
|
||||
waitRepo timeout repoKey = do
|
||||
|
||||
notice $ yellow "waitRepo" <+> pretty (AsBase58 repoKey)
|
||||
status $ yellow "waitRepo" <+> pretty (AsBase58 repoKey)
|
||||
|
||||
ask >>= \case
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
|
|
@ -260,7 +261,7 @@ waitRepo timeout repoKey = do
|
|||
|
||||
callCC \forPeer -> do
|
||||
|
||||
notice "wait for peer"
|
||||
status "wait for peer"
|
||||
|
||||
lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 2) peerAPI (repoKey, "lwwref", 31))
|
||||
>>= maybe (wait 1 forPeer ()) (const none)
|
||||
|
|
@ -270,7 +271,7 @@ waitRepo timeout repoKey = do
|
|||
pause @'Seconds 10
|
||||
|
||||
lww <- flip fix 2 \next i -> do
|
||||
notice $ "wait for" <+> pretty (AsBase58 repoKey)
|
||||
status $ "wait for" <+> pretty (AsBase58 repoKey)
|
||||
lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey))
|
||||
>>= \case
|
||||
Just (Just x) -> pure x
|
||||
|
|
@ -278,10 +279,10 @@ waitRepo timeout repoKey = do
|
|||
|
||||
setGitRepoKey repoKey
|
||||
|
||||
notice $ "lwwref value" <+> pretty (lwwValue lww)
|
||||
status $ "lwwref value" <+> pretty (lwwValue lww)
|
||||
|
||||
mf <- flip fix 3 $ \next i -> do
|
||||
notice $ "wait for manifest" <+> pretty i
|
||||
status $ "wait for manifest" <+> pretty i
|
||||
lift (try @_ @SomeException getRepoManifest) >>= \case
|
||||
Left{} -> wait i next (i*1.10)
|
||||
Right x -> pure x
|
||||
|
|
@ -305,7 +306,7 @@ waitRepo timeout repoKey = do
|
|||
void $ lift $ race waiter do
|
||||
|
||||
rv <- flip fix 1 \next i -> do
|
||||
notice $ "wait for reflog" <+> pretty i <+> pretty (AsBase58 reflog)
|
||||
status $ "wait for reflog" <+> pretty i <+> pretty (AsBase58 reflog)
|
||||
lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) reflogAPI reflog)
|
||||
>>= \case
|
||||
Just (Just x) -> pure x
|
||||
|
|
@ -316,7 +317,7 @@ waitRepo timeout repoKey = do
|
|||
|
||||
cancel pFetch
|
||||
|
||||
notice $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv
|
||||
status $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv
|
||||
|
||||
flip fix 5 $ \next w -> do
|
||||
|
||||
|
|
@ -325,7 +326,7 @@ waitRepo timeout repoKey = do
|
|||
if L.null missed then do
|
||||
updateRepoKey repoKey
|
||||
else do
|
||||
notice $ "wait reflog to sync in consistent state" <+> pretty w
|
||||
status $ "wait reflog to sync in consistent state" <+> pretty w
|
||||
pause @'Seconds w
|
||||
next (w*1.01)
|
||||
|
||||
|
|
|
|||
|
|
@ -50,6 +50,11 @@ helpEntry what = do
|
|||
pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
|
||||
pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]
|
||||
|
||||
pattern MatchOption:: forall {c} . Id -> Syntax c -> Syntax c
|
||||
pattern MatchOption n e <- ListVal [SymbolVal n, e]
|
||||
|
||||
pattern MatchFlag :: forall {c} . Id -> Syntax c
|
||||
pattern MatchFlag n <- ListVal [SymbolVal n]
|
||||
|
||||
splitOpts :: [(Id,Int)]
|
||||
-> [Syntax C]
|
||||
|
|
|
|||
Loading…
Reference in New Issue