voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

some documentation and minor refactoring

This commit is contained in:
voidlizard 2025-02-20 07:57:47 +03:00
parent 74659bffc6
commit ca033d2c1c
9 changed files with 203 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hbs2-git3/app/GitRemoteHelper.hs
View File

@ -230,6 +230,8 @@ main = flip runContT pure do
setupLogger setupLogger
setStatusOn
env <- nullGit3Env env <- nullGit3Env
ops <- DeferredOps <$> newTQueueIO ops <- DeferredOps <$> newTQueueIO

17
hbs2-git3/lib/HBS2/Git3/Logger.hs
View File

@ -1,10 +1,15 @@
{-# Language AllowAmbiguousTypes #-}
module HBS2.Git3.Logger ( setupLogger module HBS2.Git3.Logger ( setupLogger
, flushLoggers , flushLoggers
, silence , silence
, debugPrefix , debugPrefix
, status, setStatusOn, STATUS
) where ) where
import HBS2.Git3.Prelude import HBS2.Prelude
import HBS2.System.Logger.Simple.ANSI as Logger
data STATUS
-- debugPrefix :: LoggerEntry -> LoggerEntry -- debugPrefix :: LoggerEntry -> LoggerEntry
-- debugPrefix :: LoggerEntry -> LoggerEntry -- debugPrefix :: LoggerEntry -> LoggerEntry
@ -31,4 +36,14 @@ silence = do
setLoggingOff @NOTICE setLoggingOff @NOTICE
setLoggingOff @INFO 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 ""

18
hbs2-git3/lib/HBS2/Git3/Man.hs
View File

@ -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"
]

1
hbs2-git3/lib/HBS2/Git3/Prelude.hs
View File

@ -39,6 +39,7 @@ import HBS2.Storage.Operations.Class as Exported
import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.System.Logger.Simple.ANSI as Exported
import HBS2.Git3.Types as Exported import HBS2.Git3.Types as Exported
import HBS2.Git3.Logger as Exported
-- import HBS2.Git3.State.Types as Exported -- import HBS2.Git3.State.Types as Exported
import HBS2.System.Dir import HBS2.System.Dir

12
hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs
View File

@ -56,8 +56,16 @@ listRemotes = do
pure urls pure urls
resolveRepoKeyThrow :: MonadIO m => [Syntax C] -> m GitRepoKey resolveRepo :: forall c m . (IsContext c, HBS2GitPerks m) => [Syntax c] -> Git3 m ()
resolveRepoKeyThrow = \case 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 [ SignPubKeyLike url ] -> pure url
[ RepoURL url ] -> pure url [ RepoURL url ] -> pure url
[ StringLike x ] -> do [ StringLike x ] -> do

6
hbs2-git3/lib/HBS2/Git3/Repo/Types.hs
View File

@ -7,16 +7,16 @@ import Data.Config.Suckless.Script
import Data.HashSet qualified as HS import Data.HashSet qualified as HS
import Data.Text qualified as Text 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 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) pattern RepoURL3 x <- (isRepoURL [ "hbs23" ] -> Just x)
remoteRepoURL :: GitRemoteKey -> Text remoteRepoURL :: GitRemoteKey -> Text
remoteRepoURL k = Text.pack $ show $ "hbs23://" <> pretty (AsBase58 k) 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 isRepoURL pref = \case
TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of
ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk

269
hbs2-git3/lib/HBS2/Git3/Run.hs
View File

@ -96,31 +96,36 @@ compression ; prints compression level
_ -> throwIO (BadFormException @C nil) _ -> throwIO (BadFormException @C nil)
entry $ bindMatch "segment" $ nil_ $ \case brief "sets packed segment size in bytes"
[ LitIntVal n ] -> lift do $ entry $ bindMatch "segment" $ nil_ $ \case
setPackedSegmedSize (fromIntegral n) [ LitIntVal n ] -> lift do
setPackedSegmedSize (fromIntegral n)
_ -> throwIO (BadFormException @C nil) _ -> throwIO (BadFormException @C nil)
entry $ bindMatch "quiet" $ nil_ $ const $ lift do brief "silent mode"
silence $ 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 [ LitIntVal size ]-> lift do
setIndexBlockSize (fromIntegral size) setIndexBlockSize (fromIntegral size)
_ -> throwIO (BadFormException @C nil) _ -> 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" r <- gitReadTree "HEAD"
for_ r $ \GitTreeEntry{..} -> do for_ r $ \GitTreeEntry{..} -> do
liftIO $ print $ pretty gitEntryHash liftIO $ print $ fill 40 (pretty gitEntryHash)
<+> pretty gitEntryType <+> pretty gitEntryType
<+> pretty gitEntrySize <+> pretty gitEntrySize
<+> pretty gitEntryName <+> pretty gitEntryName
entry $ bindMatch "debug" $ nil_ $ const do brief "turn debug output on"
setLogging @DEBUG $ toStderr . logPrefix "[debug] " $ entry $ bindMatch "debug" $ nil_ $ const do
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
-- hidden do -- hidden do
@ -176,25 +181,26 @@ compression ; prints compression level
liftIO $ print $ "object" <+> pretty h <+> pretty s 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 hash <- case argz of
[ x@StringLike{}, GitHashLike h ] -> do [ x@StringLike{}, GitHashLike h ] -> do
resolveRepoKeyThrow [x] >>= setGitRepoKey resolveRepoKeyThrow [x] >>= setGitRepoKey
waitRepo Nothing =<< getGitRepoKeyThrow waitRepo Nothing =<< getGitRepoKeyThrow
pure h 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 for_ answ $ \bs -> do
let a = coerce (BS.take 32 bs) :: HashRef let a = coerce (BS.take 32 bs) :: HashRef
liftIO $ print $ pretty a liftIO $ print $ pretty a
entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do
sto <- getStorage sto <- getStorage
@ -218,24 +224,30 @@ compression ; prints compression level
for_ trees $ \tree -> do for_ trees $ \tree -> do
writeAsGitPack dir tree writeAsGitPack dir tree
entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift $ connectedDo do brief "prints indexed object count for repo" $
idx <- openIndex entry $ bindMatch "repo:index:count" $ nil_ $ \syn -> lift $ connectedDo do
num_ <- newIORef 0
enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x))
readIORef num_ >>= liftIO . print . pretty
entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift $ connectedDo do resolveRepo syn
files <- listObjectIndexFiles
for_ files $ \(ifn,_) -> do
lbs <- liftIO $ LBS.readFile ifn
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 brief "lists indexed objects for repo" $
& over _1 (coerce @_ @GitHash . LBS.toStrict) entry $ bindMatch "repo:index:list" $ nil_ $ \syn -> lift $ connectedDo do
& over _2 (coerce @_ @HashRef . LBS.toStrict) 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 entry $ bindMatch "reflog:index:check" $ nil_ $ \case
[ StringLike fn ] -> lift do [ StringLike fn ] -> lift do
@ -246,24 +258,26 @@ compression ; prints compression level
_ -> throwIO (BadFormException @C nil) _ -> 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 size <- getIndexBlockSize
compactIndex size 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 indexPath >>= liftIO . print . pretty
-- let entriesListOf lbs = S.toList_ $ runConsumeLBS lbs $ readSections $ \s ss -> do -- 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 files <- listObjectIndexFiles
cur <- pwd cur <- pwd
for_ files $ \(f',s) -> do for_ files $ \(f',s) -> do
let f = makeRelative cur f' let f = makeRelative cur f'
liftIO $ print $ fill 10 (pretty s) <+> pretty f liftIO $ print $ fill 10 (pretty s) <+> pretty f
entry $ bindMatch "reflog:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
r <- newIORef ( mempty :: HashSet HashRef ) r <- newIORef ( mempty :: HashSet HashRef )
index <- openIndex index <- openIndex
enumEntries index $ \bs -> do enumEntries index $ \bs -> do
@ -275,9 +289,8 @@ compression ; prints compression level
for_ z $ \h ->do for_ z $ \h ->do
liftIO $ print $ pretty h liftIO $ print $ pretty h
entry $ bindMatch "reflog:index:build" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:index:build" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
updateReflogIndex updateReflogIndex
entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case
@ -289,7 +302,9 @@ compression ; prints compression level
_ -> throwIO (BadFormException @C nil) _ -> throwIO (BadFormException @C nil)
entry $ bindMatch "git:commit:list:objects:new" $ nil_ $ \case 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 commit <- gitRevParseThrow what
@ -323,59 +338,63 @@ compression ; prints compression level
_ -> throwIO (BadFormException @C nil) _ -> throwIO (BadFormException @C nil)
entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do manGitListObjectsNew $
let (opts,argz) = splitOpts [] syn 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 void $ flip runContT pure do
let req h = lift $ indexEntryLookup idx h <&> isNothing
(t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle) lift updateReflogIndex
let s = HPSQ.size r idx <- lift openIndex
debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1) let req h = lift $ indexEntryLookup idx h <&> isNothing
cap <- liftIO getNumCapabilities (t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle)
gitCatBatchQ <- contWorkerPool cap do
che <- ContT withGitCat
pure $ gitReadObjectMaybe che
uniq_ <- newTVarIO mempty let s = HPSQ.size r
-- c1 <- newCacheFixedHPSQ 1000 debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1)
(t3, _) <- timeItT $ lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do
(_,self) <- gitCatBatchQ commit cap <- liftIO getNumCapabilities
>>= orThrow (GitReadError (show $ pretty commit)) 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
-- читаем только те объекты, которые не в индексе (_,self) <- gitCatBatchQ commit
gitReadTreeObjectsOnly commit >>= orThrow (GitReadError (show $ pretty commit))
<&> ([commit,tree]<>)
>>= \hs -> atomically (for_ hs (modifyTVar uniq_ . HS.insert))
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 debug $ "read new objects" <+> pretty (realToFrac @_ @(Fixed E2) t3)
print $ pretty n
-- notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4) (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 entry $ bindMatch "repo:tx:list:imported" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
txImported >>= liftIO . print . vcat . (fmap pretty) . HS.toList txImported >>= liftIO . print . vcat . fmap pretty . HS.toList
let (opts, argz) = splitOpts [ ("--checkpoints",0) let (opts, argz) = splitOpts [ ("--checkpoints",0)
, ("--segments",0) , ("--segments",0)
@ -402,18 +421,17 @@ compression ; prints compression level
forM_ decoded print 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) let (opts, argz) = splitOpts [ ("--checkpoints",0)
, ("--segments",0) , ("--segments",0)
] syn ] syn
let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ] let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ]
let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ] let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ]
resolveRepoKeyThrow argz >>= setGitRepoKey
waitRepo Nothing =<< getGitRepoKeyThrow
hxs <- txListAll Nothing hxs <- txListAll Nothing
liftIO $ forM_ hxs $ \(h,tx) -> do liftIO $ forM_ hxs $ \(h,tx) -> do
@ -428,65 +446,55 @@ compression ; prints compression level
forM_ decoded print forM_ decoded print
entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:refs" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
rrefs <- importedRefs rrefs <- importedRefs
for_ rrefs $ \(r,h) -> do for_ rrefs $ \(r,h) -> do
liftIO $ print $ fill 20 (pretty h) <+> pretty r liftIO $ print $ fill 20 (pretty h) <+> pretty r
entry $ bindMatch "reflog:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty) refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty)
entry $ bindMatch "repo:wait" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:wait" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
getRepoManifest >>= liftIO . print . pretty . mkForm "manifest" . coerce getRepoManifest >>= liftIO . print . pretty . mkForm "manifest" . coerce
manRemotes $ entry $ bindAlias "remotes" "repo:remotes" manRemotes $ entry $ bindAlias "remotes" "repo:remotes"
hidden $ manRemotes $
manRemotes $ entry $ bindMatch "repo:remotes" $ nil_ $ const $ lift do
entry $ bindMatch "repo:remotes" $ nil_ $ const $ lift do remotes <- listRemotes
remotes <- listRemotes liftIO $ for_ remotes $ \(r,k) -> do
liftIO $ for_ remotes $ \(r,k) -> do print $ fill 44 (pretty (AsBase58 k)) <+> pretty r
print $ fill 44 (pretty (AsBase58 k)) <+> pretty r
entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:imported" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
p <- importedCheckpoint p <- importedCheckpoint
liftIO $ print $ pretty p liftIO $ print $ pretty p
entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do hidden do
resolveRepoKeyThrow syn >>= setGitRepoKey entry $ bindMatch "repo:import" $ nil_ $ \syn -> lift $ connectedDo do
waitRepo Nothing =<< getGitRepoKeyThrow resolveRepo syn
importGitRefLog importGitRefLog
brief "shows repo manifest" $ brief "shows repo manifest" $
entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
manifest <- Repo.getRepoManifest manifest <- Repo.getRepoManifest
liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest) liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest)
brief "shows repo reflog" $ 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 repo <- Repo.getRepoManifest
reflog <- getRefLog repo & orThrow GitRepoManifestMalformed reflog <- getRefLog repo & orThrow GitRepoManifestMalformed
liftIO $ print $ pretty (AsBase58 reflog) liftIO $ print $ pretty (AsBase58 reflog)
entry $ bindMatch "repo:credentials" $ nil_ $ \syn -> lift $ connectedDo $ do entry $ bindMatch "repo:credentials" $ nil_ $ \syn -> lift $ connectedDo $ do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo (Just 10) =<< getGitRepoKeyThrow
(p,_) <- getRepoRefLogCredentials (p,_) <- getRepoRefLogCredentials
liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )] liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )]
@ -525,25 +533,21 @@ compression ; prints compression level
-- FIXME: maybe-add-default-remote -- FIXME: maybe-add-default-remote
entry $ bindMatch "repo:head" $ nil_ $ \syn -> lift $ connectedDo $ do entry $ bindMatch "repo:head" $ nil_ $ \syn -> lift $ connectedDo $ do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
lww <- getRepoRefMaybe lww <- getRepoRefMaybe
liftIO $ print $ pretty lww liftIO $ print $ pretty lww
entry $ bindMatch "repo:gk:journal:import" $ nil_ $ \syn -> lift $ connectedDo $ do entry $ bindMatch "repo:gk:journal:import" $ nil_ $ \syn -> lift $ connectedDo $ do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
importGroupKeys importGroupKeys
entry $ bindMatch "repo:gk:journal:imported" $ nil_ $ \syn -> lift $ connectedDo $ do entry $ bindMatch "repo:gk:journal:imported" $ nil_ $ \syn -> lift $ connectedDo $ do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
readGroupKeyFile <&> maybe nil (mkSym @C . show . pretty) readGroupKeyFile <&> maybe nil (mkSym @C . show . pretty)
>>= liftIO . print . pretty >>= liftIO . print . pretty
entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do
resolveRepoKeyThrow syn >>= setGitRepoKey resolveRepo syn
waitRepo Nothing =<< getGitRepoKeyThrow
ref <- getGitRepoKeyThrow ref <- getGitRepoKeyThrow
@ -573,12 +577,13 @@ compression ; prints compression level
manInit $ entry $ manInit $ entry $
bindAlias "init" "repo:init" bindAlias "init" "repo:init"
entry $ bindMatch "repo:relay-only" $ nil_ $ \case manRepoRelayOnly $
[ SignPubKeyLike repo ] -> lift $ connectedDo do entry $ bindMatch "repo:relay-only" $ nil_ $ \case
setGitRepoKey repo [ SignPubKeyLike repo ] -> lift $ connectedDo do
waitRepo (Just 10) =<< getGitRepoKeyThrow setGitRepoKey repo
waitRepo (Just 10) =<< getGitRepoKeyThrow
_ -> throwIO (BadFormException @C nil) _ -> throwIO (BadFormException @C nil)
exportEntries "reflog:" exportEntries "reflog:"

21
hbs2-git3/lib/HBS2/Git3/State.hs
View File

@ -46,6 +46,7 @@ import Codec.Compression.Zstd (maxCLevel)
newtype RepoManifest = RepoManifest [Syntax C] newtype RepoManifest = RepoManifest [Syntax C]
-- FIXME: cache -- FIXME: cache
getGK :: forall m . HBS2GitPerks m => Git3 m (Maybe (HashRef, GroupKey 'Symm 'HBS2Basic)) getGK :: forall m . HBS2GitPerks m => Git3 m (Maybe (HashRef, GroupKey 'Symm 'HBS2Basic))
getGK = do getGK = do
@ -64,7 +65,7 @@ getRefLog mf = lastMay [ x
updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m () updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m ()
updateRepoKey key = do updateRepoKey key = do
notice $ "updateRepoKey" <+> pretty (AsBase58 key) status $ "updateRepoKey" <+> pretty (AsBase58 key)
setGitRepoKey key setGitRepoKey key
@ -72,7 +73,7 @@ updateRepoKey key = do
ask >>= \case ask >>= \case
Git3Connected{..} -> do Git3Connected{..} -> do
notice $ yellow "UPDATED REFLOG" <+> pretty (fmap AsBase58 reflog) debug $ yellow "UPDATED REFLOG" <+> pretty (fmap AsBase58 reflog)
atomically $ writeTVar gitRefLog reflog atomically $ writeTVar gitRefLog reflog
_ -> none _ -> none
@ -241,7 +242,7 @@ waitRepo :: forall m . HBS2GitPerks m
-> Git3 m () -> Git3 m ()
waitRepo timeout repoKey = do waitRepo timeout repoKey = do
notice $ yellow "waitRepo" <+> pretty (AsBase58 repoKey) status $ yellow "waitRepo" <+> pretty (AsBase58 repoKey)
ask >>= \case ask >>= \case
Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Disconnected{} -> throwIO Git3PeerNotConnected
@ -260,7 +261,7 @@ waitRepo timeout repoKey = do
callCC \forPeer -> do callCC \forPeer -> do
notice "wait for peer" status "wait for peer"
lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 2) peerAPI (repoKey, "lwwref", 31)) lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 2) peerAPI (repoKey, "lwwref", 31))
>>= maybe (wait 1 forPeer ()) (const none) >>= maybe (wait 1 forPeer ()) (const none)
@ -270,7 +271,7 @@ waitRepo timeout repoKey = do
pause @'Seconds 10 pause @'Seconds 10
lww <- flip fix 2 \next i -> do 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)) lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey))
>>= \case >>= \case
Just (Just x) -> pure x Just (Just x) -> pure x
@ -278,10 +279,10 @@ waitRepo timeout repoKey = do
setGitRepoKey repoKey setGitRepoKey repoKey
notice $ "lwwref value" <+> pretty (lwwValue lww) status $ "lwwref value" <+> pretty (lwwValue lww)
mf <- flip fix 3 $ \next i -> do mf <- flip fix 3 $ \next i -> do
notice $ "wait for manifest" <+> pretty i status $ "wait for manifest" <+> pretty i
lift (try @_ @SomeException getRepoManifest) >>= \case lift (try @_ @SomeException getRepoManifest) >>= \case
Left{} -> wait i next (i*1.10) Left{} -> wait i next (i*1.10)
Right x -> pure x Right x -> pure x
@ -305,7 +306,7 @@ waitRepo timeout repoKey = do
void $ lift $ race waiter do void $ lift $ race waiter do
rv <- flip fix 1 \next i -> 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) lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) reflogAPI reflog)
>>= \case >>= \case
Just (Just x) -> pure x Just (Just x) -> pure x
@ -316,7 +317,7 @@ waitRepo timeout repoKey = do
cancel pFetch cancel pFetch
notice $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv status $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv
flip fix 5 $ \next w -> do flip fix 5 $ \next w -> do
@ -325,7 +326,7 @@ waitRepo timeout repoKey = do
if L.null missed then do if L.null missed then do
updateRepoKey repoKey updateRepoKey repoKey
else do 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 pause @'Seconds w
next (w*1.01) next (w*1.01)

5
miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs
View File

@ -50,6 +50,11 @@ helpEntry what = do
pattern HelpEntryBound :: forall {c}. Id -> [Syntax c] pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] 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)] splitOpts :: [(Id,Int)]
-> [Syntax C] -> [Syntax C]