diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs index f4c0c8e2..abaabe56 100644 --- a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs @@ -480,6 +480,19 @@ applyLambda decl body args = do atomically $ writeTVar tv d0 pure e +apply_ :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => Syntax c + -> [Syntax c] + -> RunM c m (Syntax c) + +apply_ s args = case s of + ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> apply n args + SymbolVal what -> apply what args + Lambda d body -> applyLambda d body args + e -> throwIO $ BadFormException @c s apply :: forall c m . ( IsContext c , MonadUnliftIO m @@ -562,6 +575,10 @@ eval syn = handle (handleForm syn) $ do ListVal (SymbolVal "begin" : what) -> do evalTop what + e@(ListVal (SymbolVal "blob" : what)) -> do + pure e + -- evalTop what + lc@(ListVal (Lambda decl body : args)) -> do applyLambda decl body args diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs index b99a361c..dfbe95aa 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs @@ -5,6 +5,7 @@ import HBS2.CLI.Run.Internal import HBS2.CLI.Run.Internal.KeyMan import HBS2.Data.Types.Refs +import HBS2.Merkle import HBS2.Storage import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix @@ -31,6 +32,8 @@ import Data.Text.Encoding qualified as TE import Data.Text qualified as Text import Control.Monad.Trans.Cont +import Streaming.Prelude qualified as S + getCredentialsForReflog :: MonadUnliftIO m => RefLogKey 'HBS2Basic -> m (PeerCredentials 'HBS2Basic) getCredentialsForReflog reflog = do runKeymanClient (loadCredentials reflog) @@ -166,5 +169,54 @@ reflogEntries = do _ -> throwIO (BadFormException @C nil) + entry $ bindMatch "hbs2:reflog:tx:seqref:decode" $ \case + [ListVal [SymbolVal "blob", LitStrVal s]] -> do + let lbs = Text.unpack s & BS8.pack & LBS.fromStrict + + SequentialRef n (AnnotatedHashRef _ h) <- deserialiseOrFail @SequentialRef lbs + & orThrowUser "FUCKED" + + pure $ mkForm "seqref" [mkInt n, mkStr (show $ pretty h)] + + e -> throwIO $ BadFormException @c nil + + entry $ bindMatch "hbs2:reflog:tx:list" $ \case + [e, SignPubKeyLike puk] -> do + + flip runContT pure do + + callCC \exit -> do + + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @RefLogAPI @UNIX so + sto <- ContT withPeerStorage + + r <- callService @RpcRefLogGet api puk + >>= orThrowUser "can't get reflog value" + + rlh <- ContT $ maybe1 r (pure nil) + + hashes <- S.toList_ do + walkMerkle @[HashRef] (fromHashRef rlh) (getBlock sto) $ \case + (Left _) -> lift $ exit nil + (Right (hs :: [HashRef])) -> S.each hs + + rr <- forM hashes $ \ha -> do + + tx <- getBlock sto (coerce ha) + >>= orThrowUser "missed-block" + <&> deserialiseOrFail @(RefLogUpdate L4Proto) + >>= orThrowUser "invalid-tx" + + let bs = view refLogUpdData tx + let bs8 = BS8.unpack bs + + lift $ apply_ e [mkForm "blob" [mkStr bs8]] + + pure $ mkList rr + + _ -> throwIO (BadFormException @C nil) + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs index 31f6503c..2dde982d 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs @@ -157,6 +157,8 @@ verifyRefLogUpdate msg = do let sign = view refLogUpdSign msg pure $ verifySign @s pubk sign noncebs +-- unpackRef + data RefLogRequestI e m = RefLogRequestI { onRefLogRequest :: (Peer e, PubKey 'Sign (Encryption e)) -> m (Maybe (Hash HbSync))