wip

hbs2-peer/app/CLI/Mailbox.hs

@@ -51,6 +51,8 @@ pMailBox = do
  what <- many (strArgument (metavar "ARGS" <> help "hbs2-cli mailbox command-line"))
  pure (runMailboxCLI rpc what)
 
+
+
 runMailboxCLI :: RPCOpt -> [String] -> IO ()
 runMailboxCLI rpc s = do
 
@@ -70,39 +72,8 @@ runMailboxCLI rpc s = do
           liftIO $ print $ pretty "okay, rpc is here"
 
         brief "creates mailbox of given type" $
-          desc [qc|
-; creates a mailbox using recipient SIGN public key
-
-create --key KEY TYPE
-
-; creates a mailbox using key from a SIGIL with HASH (should stored first)
-
-create --sigil HASH TYPE
-
-; creates a mailbox using key from a SIGIL from FILE
-
-create --sigil-file FILE TYPE
-
-TYPE ::= hub | relay
-
-|] $
-          examples [qc|
-
-; create using recipient public key
-
-create --key 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV relay
-
-; create using sigil hash
-
-create --sigil ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh relay
-
-; create using sigil file
-
-create --sigil-file ./my.sigil hub
-
-see hbs2-cli for sigil commands (create, store, load, etc)
-
-|]
+          desc createMailBoxDesc $
+          examples createMailBoxExamples
             $ entry $ bindMatch "create" $ nil_ $ \syn -> do
 
               case syn of
@@ -126,29 +97,7 @@ see hbs2-cli for sigil commands (create, store, load, etc)
                 _ -> throwIO $ BadFormException @C nil
 
         brief "send message via gossip"  $
-          desc [qc|
-; reads message blob from stdin
-
-send --stdin
-
-; read message blob from file
-
-send --file FILE
-
-; reads message blob from storage
-
-send HASH
-
-you may create a message from plain text using
-
-hbs2-cli hbs2:mailbox:message:create
-
-command
-
-SEE ALSO
-  hbs2:mailbox:message:create
-
-          |]
+          desc sendMessageDesc
           $ entry $ bindMatch "send" $ nil_ $ \syn -> do
 
               blob <- case syn of
@@ -172,6 +121,27 @@ SEE ALSO
 
               pure ()
 
+        brief "get mailbox value"
+          $ entry $ bindMatch "get" $ nil_ $ \case
+             [ SignPubKeyLike m ] -> do
+
+              v <- callRpcWaitMay @RpcMailboxGet t api m
+                     >>= orThrowUser "rpc call timeout"
+
+              liftIO $ print $ pretty v
+
+             _ -> throwIO $ BadFormException @C nil
+
+        brief "list mailboxes"
+          $ entry $ bindMatch "list" $ nil_ $ const do
+
+              let fmtMbox (m,t) = pretty m <+> pretty t
+
+              v <- callRpcWaitMay @RpcMailboxList t api ()
+                     >>= orThrowUser "rpc call timeout"
+
+              liftIO $ print $ vcat (fmap fmtMbox v)
+
         entry $ bindMatch "help" $ nil_ \case
           HelpEntryBound what -> helpEntry what
           [StringLike s]      -> helpList False (Just s)
@@ -184,3 +154,68 @@ SEE ALSO
     let sto = AnyStorage (StorageClient stoAPI)
     lift $ run (dict sto caller) cli >>= eatNil display
 
+
+-- man entries
+
+createMailBoxDesc :: Doc a
+createMailBoxDesc = [qc|
+; creates a mailbox using recipient SIGN public key
+
+create --key KEY TYPE
+
+; creates a mailbox using key from a SIGIL with HASH (should stored first)
+
+create --sigil HASH TYPE
+
+; creates a mailbox using key from a SIGIL from FILE
+
+create --sigil-file FILE TYPE
+
+TYPE ::= hub | relay
+
+|]
+
+createMailBoxExamples :: ManExamples
+createMailBoxExamples = [qc|
+; create using recipient public key
+
+create --key 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV relay
+
+; create using sigil hash
+
+create --sigil ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh relay
+
+; create using sigil file
+
+create --sigil-file ./my.sigil hub
+
+see hbs2-cli for sigil commands (create, store, load, etc)
+
+|]
+
+
+sendMessageDesc :: Doc a
+sendMessageDesc = [qc|
+; reads message blob from stdin
+
+send --stdin
+
+; read message blob from file
+
+send --file FILE
+
+; reads message blob from storage
+
+send HASH
+
+you may create a message from plain text using
+
+hbs2-cli hbs2:mailbox:message:create
+
+command
+
+SEE ALSO
+  hbs2:mailbox:message:create
+
+|]
+

hbs2-peer/app/MailboxProtoWorker.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language UndecidableInstances #-}
 module MailboxProtoWorker ( mailboxProtoWorker
@@ -120,6 +121,21 @@ instance ( s ~ Encryption e, e ~ L4Proto
 
     pure $ Right ()
 
+  mailboxListBasic  MailboxProtoWorker{..} = do
+
+    flip runContT pure do
+
+      mdbe <- readTVarIO mailboxDB
+
+      dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready"))
+
+      debug $ red "mailboxListBasic"
+
+      r <- withDB dbe do
+             select_ @_ @(MailboxRefKey s, MailboxType) [qc|select recipient,type from mailbox|]
+
+      pure $ Right r
+
 getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> Recipient s -> m (Maybe MailboxType)
 getMailboxType_ d r = do
   let sql = [qc|select type from mailbox where recipient = ? limit 1|]
@@ -264,7 +280,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
         let mergedTx = HS.fromList txs <> newTx & HS.toList
 
         -- FIXME: size-hardcode-again
-        let pt = toPTree (MaxSize 6000) (MaxNum 256) mergedTx
+        let pt = toPTree (MaxSize 6000) (MaxNum 1024) mergedTx
         nref <- makeMerkle 0 pt $ \(_,_,bss) -> void $ liftIO $ putBlock sto bss
 
         updateRef sto r nref
@@ -308,3 +324,11 @@ mailboxStateEvolve readConf MailboxProtoWorker{..}  = do
 
   pure dbe
 
+
+instance ForMailbox s => FromField (MailboxRefKey s) where
+  fromField w = fromField @String w <&> fromString @(MailboxRefKey s)
+
+instance FromField MailboxType where
+  fromField w = fromField @String w <&> fromString @MailboxType
+
+

hbs2-peer/app/RPC2/Mailbox.hs

@@ -4,11 +4,13 @@ module RPC2.Mailbox where
 
 import HBS2.Peer.Prelude
 
+import HBS2.Data.Types.Refs
 import HBS2.Base58
 import HBS2.Actors.Peer
 import HBS2.Data.Types.SignedBox
 import HBS2.Peer.Proto
 import HBS2.Peer.Proto.Mailbox
+import HBS2.Peer.Proto.Mailbox.Ref
 import HBS2.Storage
 import HBS2.Net.Messaging.Unix
 import HBS2.Misc.PrettyStuff
@@ -20,6 +22,7 @@ import PeerTypes
 import HBS2.Peer.RPC.Internal.Types
 import HBS2.Peer.RPC.API.Mailbox
 
+import Data.Either
 import Lens.Micro.Platform
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
@@ -43,6 +46,13 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where
     debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t
 
 
+instance (ForMailboxRPC m) => HandleMethod m RpcMailboxList where
+
+  handleMethod _ = do
+    AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService
+    r <- mailboxListBasic @HBS2Basic mbs
+    pure $ fromRight mempty r
+
 instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSend where
 
   handleMethod mess = do
@@ -51,3 +61,12 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSend where
     debug $ "rpc.RpcMailboxSend"
     void $ mailboxSendMessage w mess
 
+instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGet where
+
+  handleMethod mbox = do
+    RPC2Context{..} <- getRpcContext @MailboxAPI @RPC2Context
+    debug $ "rpc.RpcMailboxGet"
+    getRef rpcStorage (MailboxRefKey @HBS2Basic mbox)
+             <&> fmap HashRef
+
+

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs

@@ -103,15 +103,20 @@ class ForMailbox s => IsMailboxService s a where
                      -> Message s
                      -> m (Either MailboxServiceError ())
 
+  mailboxListBasic :: forall m . MonadIO m
+                   => a
+                   -> m (Either MailboxServiceError [(MailboxRefKey s, MailboxType)])
+
 data AnyMailboxService s =
   forall a  . (IsMailboxService s a) => AnyMailboxService { mailboxService :: a }
 
 data AnyMailboxAdapter s =
-  forall a . (IsMailboxProtoAdapter s a) => AnyMailboxAdapter { mailboxAdapter :: a}
+  forall a . (IsMailboxProtoAdapter s a) => AnyMailboxAdapter { mailboxAdapter :: a }
 
 instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where
   mailboxCreate (AnyMailboxService a) = mailboxCreate @s a
   mailboxSendMessage (AnyMailboxService a) = mailboxSendMessage @s a
+  mailboxListBasic (AnyMailboxService a) = mailboxListBasic @s a
 
 instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
   mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs

@@ -3,6 +3,9 @@ module HBS2.Peer.Proto.Mailbox.Ref where
 
 
 import HBS2.Prelude
+
+import HBS2.Peer.Proto.Mailbox.Types
+
 import HBS2.Hash
 import HBS2.Base58
 import HBS2.Net.Proto.Types
@@ -12,6 +15,7 @@ import Data.Maybe (fromMaybe)
 import Data.Hashable hiding (Hashed)
 
 newtype MailboxRefKey s = MailboxRefKey (PubKey 'Sign s)
+                          deriving stock Generic
 
 instance RefMetaData (MailboxRefKey s)
 
@@ -35,4 +39,5 @@ instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (AsBase58 (MailboxRefKey s
 instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (MailboxRefKey s) where
   pretty (MailboxRefKey k) = pretty (AsBase58 k)
 
+instance ForMailbox s => Serialise (MailboxRefKey s)
 

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs

@@ -25,6 +25,7 @@ import HBS2.Net.Auth.GroupKeySymm
 
 import Data.Word (Word32)
 import Codec.Serialise
+import Data.Maybe
 
 data MailboxType =
   MailboxHub | MailboxRelay
@@ -77,5 +78,6 @@ instance FromStringMaybe MailboxType where
     "relay" -> Just MailboxRelay
     _       -> Nothing
 
-
+instance IsString MailboxType where
+  fromString s = fromMaybe (error "invalid MailboxType value") (fromStringMay s)
 

hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs

@@ -16,11 +16,15 @@ import Codec.Serialise
 
 data RpcMailboxPoke
 data RpcMailboxCreate
+data RpcMailboxList
 data RpcMailboxSend
+data RpcMailboxGet
 
 type MailboxAPI = '[ RpcMailboxPoke
                    , RpcMailboxCreate
+                   , RpcMailboxList
                    , RpcMailboxSend
+                   , RpcMailboxGet
                    ]
 
 type MailboxAPIProto =  0x056091510d3b2ec9
@@ -38,7 +42,12 @@ type instance Output RpcMailboxPoke  = ()
 type instance Input RpcMailboxCreate   = (PubKey 'Sign HBS2Basic, MailboxType)
 type instance Output RpcMailboxCreate  = ()
 
+type instance Input RpcMailboxList   = ()
+type instance Output RpcMailboxList  = [(MailboxRefKey 'HBS2Basic, MailboxType)]
+
 type instance Input RpcMailboxSend  = (Message HBS2Basic)
 type instance Output RpcMailboxSend = ()
 
+type instance Input RpcMailboxGet = (PubKey 'Sign HBS2Basic)
+type instance Output RpcMailboxGet = (Maybe HashRef)