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
setStatusOn
env <- nullGit3Env
ops <- DeferredOps <$> newTQueueIO

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

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

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.Git3.Types as Exported
import HBS2.Git3.Logger as Exported
-- import HBS2.Git3.State.Types as Exported
import HBS2.System.Dir

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

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

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.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

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

@ -96,30 +96,35 @@ compression ; prints compression level
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "segment" $ nil_ $ \case
brief "sets packed segment size in bytes"
$ entry $ bindMatch "segment" $ nil_ $ \case
[ LitIntVal n ] -> lift do
setPackedSegmedSize (fromIntegral n)
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "quiet" $ nil_ $ const $ lift do
brief "silent mode"
$ entry $ bindMatch "quiet" $ nil_ $ const $ lift do
silence
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
brief "turn debug output on"
$ entry $ bindMatch "debug" $ nil_ $ const do
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
-- hidden do
@ -176,6 +181,7 @@ compression ; prints compression level
liftIO $ print $ "object" <+> pretty h <+> pretty s
hidden $
entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do
let (_, argz) = splitOpts [] syn
@ -218,13 +224,19 @@ compression ; prints compression level
for_ trees $ \tree -> do
writeAsGitPack dir tree
entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift $ connectedDo do
brief "prints indexed object count for repo" $
entry $ bindMatch "repo:index:count" $ nil_ $ \syn -> lift $ connectedDo do
resolveRepo syn
idx <- openIndex
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
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
@ -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,10 +338,14 @@ compression ; prints compression level
_ -> throwIO (BadFormException @C nil)
manGitListObjectsNew $
entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do
let (opts,argz) = splitOpts [] syn
let what = headDef "HEAD" [ x | StringLike x <- argz ]
resolveRepo syn
let (opts,argz) = splitOpts [("-r", 1)] (tail syn)
let what = headDef "HEAD" [ x | MatchOption "-r" (StringLike x) <- opts ]
h0 <- gitRevParseThrow what
@ -372,10 +391,10 @@ compression ; prints compression level
-- 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,7 +421,9 @@ 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)
@ -411,9 +432,6 @@ compression ; prints compression level
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
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
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,6 +577,7 @@ compression ; prints compression level
manInit $ entry $
bindAlias "init" "repo:init"
manRepoRelayOnly $
entry $ bindMatch "repo:relay-only" $ nil_ $ \case
[ SignPubKeyLike repo ] -> lift $ connectedDo do
setGitRepoKey repo

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

@ -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)

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