mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
parent
7b7e44414f
commit
a3bffd2f00
|
@ -135,6 +135,8 @@ export mbh refs = withStateDo do
|
||||||
reflog <- getGitRemoteKey
|
reflog <- getGitRemoteKey
|
||||||
>>= orThrowUser "reflog not set"
|
>>= orThrowUser "reflog not set"
|
||||||
|
|
||||||
|
gk' <- getGK
|
||||||
|
|
||||||
lift $ fix \next -> atomically (readTBQueue hbs2Q) >>= \case
|
lift $ fix \next -> atomically (readTBQueue hbs2Q) >>= \case
|
||||||
Nothing -> none
|
Nothing -> none
|
||||||
Just (fn,_) -> void $ flip runContT pure do
|
Just (fn,_) -> void $ flip runContT pure do
|
||||||
|
@ -143,14 +145,16 @@ export mbh refs = withStateDo do
|
||||||
ts <- liftIO getPOSIXTime <&> round
|
ts <- liftIO getPOSIXTime <&> round
|
||||||
lbs <- LBS.readFile fn
|
lbs <- LBS.readFile fn
|
||||||
let meta = mempty
|
let meta = mempty
|
||||||
let gk = Nothing
|
|
||||||
|
|
||||||
exported <- readTVarIO _exported
|
exported <- readTVarIO _exported
|
||||||
debug $ red "EXPORTED" <+> pretty exported
|
debug $ red "EXPORTED" <+> pretty exported
|
||||||
|
|
||||||
|
let gkh = fst <$> gk'
|
||||||
|
let gk = snd <$> gk'
|
||||||
|
|
||||||
when (exported > 0) do
|
when (exported > 0) do
|
||||||
href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO
|
href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO
|
||||||
writeLogEntry ("tree" <+> pretty ts <+> pretty href)
|
writeLogEntry ("tree" <+> pretty ts <+> pretty href )
|
||||||
debug $ "SENDING" <+> pretty href <+> pretty fn
|
debug $ "SENDING" <+> pretty href <+> pretty fn
|
||||||
|
|
||||||
let payload = LBS.toStrict $ serialise (AnnotatedHashRef Nothing href)
|
let payload = LBS.toStrict $ serialise (AnnotatedHashRef Nothing href)
|
||||||
|
|
|
@ -14,6 +14,7 @@ import HBS2.Git3.State
|
||||||
import HBS2.Git3.Repo qualified as Repo
|
import HBS2.Git3.Repo qualified as Repo
|
||||||
import HBS2.Git3.Repo
|
import HBS2.Git3.Repo
|
||||||
import HBS2.Git3.Logger
|
import HBS2.Git3.Logger
|
||||||
|
import HBS2.Net.Auth.GroupKeySymm
|
||||||
|
|
||||||
import Data.Config.Suckless.Script
|
import Data.Config.Suckless.Script
|
||||||
import Data.Config.Suckless.Almost.RPC
|
import Data.Config.Suckless.Almost.RPC
|
||||||
|
@ -440,6 +441,12 @@ compression ; prints compression level
|
||||||
(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) )]
|
||||||
|
|
||||||
|
entry $ bindMatch "repo:gk" $ nil_ $ \syn -> lift $ connectedDo $ do
|
||||||
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
||||||
|
gk' <- getGK
|
||||||
|
for_ gk' $ \(gkh, _) -> do
|
||||||
|
liftIO $ print $ pretty $ mkForm @C "gk" [ mkSym (show $ pretty gkh) ]
|
||||||
|
|
||||||
entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
|
entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
|
||||||
Repo.initRepo syn
|
Repo.initRepo syn
|
||||||
|
|
||||||
|
|
|
@ -15,6 +15,8 @@ import HBS2.Git3.State.Internal.RefLog as Exported
|
||||||
import HBS2.Git3.State.Internal.Segment as Exported
|
import HBS2.Git3.State.Internal.Segment as Exported
|
||||||
import HBS2.Git3.State.Internal.Index as Exported
|
import HBS2.Git3.State.Internal.Index as Exported
|
||||||
|
|
||||||
|
import HBS2.Net.Auth.GroupKeySymm
|
||||||
|
|
||||||
import HBS2.Storage.Operations.Missed
|
import HBS2.Storage.Operations.Missed
|
||||||
import HBS2.Net.Auth.Credentials
|
import HBS2.Net.Auth.Credentials
|
||||||
import HBS2.KeyMan.Keys.Direct
|
import HBS2.KeyMan.Keys.Direct
|
||||||
|
@ -44,6 +46,15 @@ import Codec.Compression.Zstd (maxCLevel)
|
||||||
|
|
||||||
newtype RepoManifest = RepoManifest [Syntax C]
|
newtype RepoManifest = RepoManifest [Syntax C]
|
||||||
|
|
||||||
|
-- FIXME: cache
|
||||||
|
getGK :: forall m . HBS2GitPerks m => Git3 m (Maybe (HashRef, GroupKey 'Symm 'HBS2Basic))
|
||||||
|
getGK = do
|
||||||
|
sto <- getStorage
|
||||||
|
mf <- getRepoManifest
|
||||||
|
runMaybeT do
|
||||||
|
gkh <- headMay [ x | ListVal [SymbolVal "gk", HashLike x ] <- coerce mf ] & toMPlus
|
||||||
|
gk <- loadGroupKeyMaybe sto gkh >>= toMPlus
|
||||||
|
pure (gkh,gk)
|
||||||
|
|
||||||
getRefLog :: RepoManifest -> Maybe GitRemoteKey
|
getRefLog :: RepoManifest -> Maybe GitRemoteKey
|
||||||
getRefLog mf = lastMay [ x
|
getRefLog mf = lastMay [ x
|
||||||
|
|
Loading…
Reference in New Issue