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

wip, basic read messages

This commit is contained in:
voidlizard 2024-10-11 08:48:05 +03:00
parent 4125b23123
commit 868068d1cc
1 changed files with 42 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
hbs2-peer/app/CLI/Mailbox.hs
View File

@ -5,6 +5,7 @@ module CLI.Mailbox (pMailBox) where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import HBS2.Hash import HBS2.Hash
import HBS2.OrDie import HBS2.OrDie
import HBS2.Merkle
import HBS2.Data.Types.Refs import HBS2.Data.Types.Refs
import HBS2.Net.Proto.Service import HBS2.Net.Proto.Service
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
@ -12,6 +13,7 @@ import HBS2.Storage
import HBS2.Data.Types.SignedBox import HBS2.Data.Types.SignedBox
import HBS2.Peer.Proto.Mailbox import HBS2.Peer.Proto.Mailbox
import HBS2.Peer.Proto.Mailbox.Types import HBS2.Peer.Proto.Mailbox.Types
import HBS2.Peer.Proto.Mailbox.Entry
import HBS2.Peer.RPC.API.Mailbox import HBS2.Peer.RPC.API.Mailbox
import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.API.Storage
@ -24,9 +26,12 @@ import PeerLogger hiding (info)
import Codec.Serialise import Codec.Serialise
import Control.Monad.Trans.Cont import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
import Data.Coerce import Data.Coerce
import Data.Config.Suckless.Script import Data.Config.Suckless.Script
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.Maybe import Data.Maybe
import Data.Word import Data.Word
import Lens.Micro.Platform import Lens.Micro.Platform
@ -142,6 +147,43 @@ runMailboxCLI rpc s = do
liftIO $ print $ vcat (fmap fmtMbox v) liftIO $ print $ vcat (fmap fmtMbox v)
brief "list messages"
$ entry $ bindMatch "list:messages" $ nil_ $ \case
[ SignPubKeyLike m ] -> void $ runMaybeT do
v <- lift (callRpcWaitMay @RpcMailboxGet t api m)
>>= orThrowUser "rpc call timeout"
>>= toMPlus
d <- liftIO $ newTVarIO (mempty :: HashSet HashRef)
r <- liftIO $ newTVarIO (mempty :: HashSet HashRef)
walkMerkle @[HashRef] (coerce v) (liftIO . getBlock sto) $ \case
Left what -> err $ "missed block for tree" <+> pretty v <+> pretty what
Right hs -> void $ runMaybeT do
for_ hs $ \h -> do
-- TODO: better-error-handling
e <- getBlock sto (coerce h)
>>= toMPlus
<&> deserialiseOrFail @MailboxEntry
>>= toMPlus
case e of
Deleted mh -> do
atomically $ modifyTVar d (HS.insert mh)
Existed mh -> do
atomically $ modifyTVar r (HS.insert mh)
deleted <- readTVarIO d
rest <- readTVarIO r
for_ (HS.difference rest deleted) $ \mh -> do
liftIO $ print $ pretty mh
_ -> throwIO $ BadFormException @C nil
entry $ bindMatch "help" $ nil_ \case entry $ bindMatch "help" $ nil_ \case
HelpEntryBound what -> helpEntry what HelpEntryBound what -> helpEntry what
[StringLike s] -> helpList False (Just s) [StringLike s] -> helpList False (Just s)