cli & rpc & context boilerplate

hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs

@@ -60,7 +60,6 @@ sigilEntries = do
     $ entry $ bindMatch "hbs2:sigil:load:base58" $ \case
       [HashLike key] -> lift do
         sto <- getStorage
-        warn $ pretty key
         r <- loadSigil @HBS2Basic sto key >>= orThrowUser "no sigil found"
         pure $ mkStr @c ( show $ pretty $ AsBase58 r  )
 

hbs2-peer/app/CLI/Mailbox.hs

@@ -1,11 +1,15 @@
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
 module CLI.Mailbox (pMailBox) where
 
 import HBS2.Prelude.Plated
 import HBS2.OrDie
+import HBS2.Data.Types.Refs
 import HBS2.Net.Proto.Service
 import HBS2.Net.Auth.Credentials
 import HBS2.Data.Types.SignedBox
-import HBS2.Peer.Proto.LWWRef
+import HBS2.Peer.Proto.Mailbox
+import HBS2.Peer.Proto.Mailbox.Types
 
 import HBS2.Peer.RPC.API.Mailbox
 import HBS2.KeyMan.Keys.Direct
@@ -25,7 +29,17 @@ import Data.Maybe
 
 import Data.Word
 import Lens.Micro.Platform
+import UnliftIO
 
+import Text.InterpolatedString.Perl6 (qc)
+
+pattern MailboxTypeLike :: forall {c}. MailboxType -> Syntax c
+pattern MailboxTypeLike w <- (mailboxTypeLike -> Just w)
+
+mailboxTypeLike :: Syntax c -> Maybe MailboxType
+mailboxTypeLike = \case
+  StringLike s -> fromStringMay @MailboxType s
+  _            -> Nothing
 
 pMailBox :: Parser (IO ())
 pMailBox = do
@@ -51,13 +65,61 @@ runMailboxCLI rpc s = do
 
           liftIO $ print $ pretty "okay, rpc is here"
 
-        entry $ bindMatch "create" $ nil_ $ const do
+        brief "creates mailbox of given type" $
-          warn "mailbox create is not here yet"
+          desc [qc|
-          -- TODO: mailbox-create
+; creates a mailbox using recipient SIGN public key
-          --  - [ ] answer: via RPC or direct
+
-          --  - [ ] answer: peer state or separate database (separate)
+create --key KEY TYPE
-          --  - [ ] implement: MailboxWorker
+
-          --  - [ ] implement: interwire MailboxWorker and mailboxProto
+; 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)
+
+|]
+            $ entry $ bindMatch "create" $ nil_ $ \syn -> do
+
+              case syn of
+                [ StringLike "--key", SignPubKeyLike puk, MailboxTypeLike tp ] -> do
+
+                  _ <- callRpcWaitMay @RpcMailboxCreate t api (puk, tp)
+                         >>= orThrowUser "rpc call timeout"
+
+                  liftIO $ print $ pretty "done"
+
+                [ StringLike "--sigil", HashLike sh, StringLike tp ] -> do
+                  -- TODO: implement-create-by-sigil
+                  warn $ "create by sigil (hash)"
+                  error "not implemented"
+
+                [ StringLike "--sigil-file", StringLike f, StringLike tp ] -> do
+                  -- TODO: implement-create-by-sigil-file
+                  warn $ "create by sigil file" <+> pretty f
+                  error "not implemented"
+
+                _ -> throwIO $ BadFormException @C nil
 
         entry $ bindMatch "help" $ nil_ \case
           HelpEntryBound what -> helpEntry what

hbs2-peer/app/MailboxProtoWorker.hs

@@ -67,6 +67,11 @@ instance (s ~ HBS2Basic) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) whe
       else do
         writeTBQueue inMessageQueue (m,c)
 
+instance (s ~ HBS2Basic) => IsMailboxService s (MailboxProtoWorker s e) where
+  mailboxCreate _ t p = do
+    debug $ "mailboxWorker.mailboxCreate" <+> pretty (AsBase58 p) <+> pretty t
+    pure $ Right ()
+
 createMailboxProtoWorker :: forall e m . MonadIO m
                          => AnyStorage
                          -> m (MailboxProtoWorker (Encryption e) e)

hbs2-peer/app/PeerMain.hs

@@ -902,6 +902,8 @@ runPeer opts = Exception.handle (\e -> myException e
 
   rcw <- async $ liftIO $ runRefChanRelyWorker rce refChanAdapter
 
+  mailboxWorker <- createMailboxProtoWorker @e (AnyStorage s)
+
   let onNoBlock (p, h) = do
         already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
         unless already do
@@ -1111,13 +1113,12 @@ runPeer opts = Exception.handle (\e -> myException e
                 peerThread "lwwRefWorker" (lwwRefWorker @e conf (SomeBrains brains))
 
                 -- setup mailboxes stuff
-                mbw <- createMailboxProtoWorker @e (AnyStorage s)
                 let defConf = coerce conf
                 let mboxConf = maybe1 pref defConf $ \p -> do
                        let mboxDir = takeDirectory (coerce p) </> "hbs2-mailbox"
                        mkList [mkSym hbs2MailboxDirOpt, mkStr mboxDir] : coerce defConf
 
-                peerThread "mailboxProtoWorker" (mailboxProtoWorker (pure mboxConf) mbw)
+                peerThread "mailboxProtoWorker" (mailboxProtoWorker (pure mboxConf) mailboxWorker)
 
                 liftIO $ withPeerM penv do
                   runProto @e
@@ -1135,7 +1136,7 @@ runPeer opts = Exception.handle (\e -> myException e
                     , makeResponse (refChanNotifyProto False refChanAdapter)
                     -- TODO: change-all-to-authorized
                     , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProtoA)
-                    , makeResponse ((authorized . mailboxProto) mbw)
+                    , makeResponse ((authorized . mailboxProto) mailboxWorker)
                     ]
 
 
@@ -1231,6 +1232,7 @@ runPeer opts = Exception.handle (\e -> myException e
                            , rpcDoRefChanHeadPost = refChanHeadPostAction
                            , rpcDoRefChanPropose = refChanProposeAction
                            , rpcDoRefChanNotify = refChanNotifyAction
+                           , rpcMailboxService = AnyMailboxService @s mailboxWorker
                            }
 
   m1 <- async $ runMessagingUnix rpcmsg

hbs2-peer/app/RPC2/Mailbox.hs

@@ -4,6 +4,7 @@ module RPC2.Mailbox where
 
 import HBS2.Peer.Prelude
 
+import HBS2.Base58
 import HBS2.Actors.Peer
 import HBS2.Data.Types.SignedBox
 import HBS2.Peer.Proto
@@ -12,6 +13,8 @@ import HBS2.Storage
 import HBS2.Net.Messaging.Unix
 import HBS2.Misc.PrettyStuff
 
+import HBS2.Peer.RPC.API.Peer
+
 import PeerTypes
 
 import HBS2.Peer.RPC.Internal.Types
@@ -21,9 +24,22 @@ import Lens.Micro.Platform
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
 
+type ForMailboxRPC m = (MonadIO m, HasRpcContext MailboxAPI RPC2Context m)
+
 
 instance (MonadIO m) => HandleMethod m RpcMailboxPoke where
 
   handleMethod key = do
     debug "rpc.RpcMailboxPoke"
 
+instance Monad m => HasRpcContext MailboxAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where
+  getRpcContext = lift ask
+
+instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where
+
+  handleMethod (puk, t) = do
+    AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService
+    void $ mailboxCreate @HBS2Basic mbs t puk
+    debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t
+
+

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

@@ -82,6 +82,15 @@ class IsMailboxProtoAdapter s a where
                         -> MessageContent s
                         -> m ()
 
+data MailboxServiceError =
+  MailboxCreateFailed
+  deriving stock (Typeable,Show)
+
+class IsMailboxService s a where
+  mailboxCreate :: forall m . MonadIO m => a -> MailboxType -> Recipient s -> m (Either MailboxServiceError ())
+
+data AnyMailboxService s = forall a  . (IsMailboxService s a) => AnyMailboxService { adapter :: a }
+
 mailboxProto :: forall e s m p a . ( MonadIO m
                                    , Response e p m
                                    , HasDeferred p e m

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

@@ -3,6 +3,7 @@
 module HBS2.Peer.Proto.Mailbox.Types
   ( ForMailbox
   , MailboxKey
+  , MailboxType(..)
   , Recipient
   , Sender
   , PolicyVersion
@@ -24,6 +25,10 @@ import HBS2.Net.Auth.GroupKeySymm
 import Data.Word (Word32)
 import Codec.Serialise
 
+data MailboxType =
+  MailboxHub | MailboxRelay
+  deriving stock (Eq,Ord,Show,Generic)
+
 type MailboxKey s = PubKey 'Sign s
 
 type Sender s = PubKey 'Sign s
@@ -57,4 +62,18 @@ type ForMailbox s = ( ForGroupKeySymm s
 instance Serialise SimplePredicate
 instance Serialise SimplePredicateExpr
 instance Serialise MailboxMessagePredicate
+instance Serialise MailboxType
+
+instance Pretty MailboxType where
+  pretty = \case
+    MailboxHub -> "hub"
+    MailboxRelay -> "relay"
+
+instance FromStringMaybe MailboxType where
+  fromStringMay = \case
+    "hub"   -> Just MailboxHub
+    "relay" -> Just MailboxRelay
+    _       -> Nothing
+
+
 

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

@@ -7,13 +7,17 @@ import HBS2.Net.Messaging.Unix (UNIX)
 import HBS2.Data.Types.Refs (HashRef(..))
 import HBS2.Data.Types.SignedBox
 
+import HBS2.Peer.Proto.Mailbox.Types
+
 import Data.ByteString.Lazy ( ByteString )
 import Data.ByteString qualified as BS
 import Codec.Serialise
 
 data RpcMailboxPoke
+data RpcMailboxCreate
 
 type MailboxAPI = '[ RpcMailboxPoke
+                   , RpcMailboxCreate
                    ]
 
 type MailboxAPIProto =  0x056091510d3b2ec9
@@ -28,7 +32,7 @@ instance HasProtocol UNIX  (ServiceProto MailboxAPI UNIX) where
 type instance Input RpcMailboxPoke   = ()
 type instance Output RpcMailboxPoke  = ()
 
-
+type instance Input RpcMailboxCreate   = (PubKey 'Sign HBS2Basic, MailboxType)
-
+type instance Output RpcMailboxCreate  = ()
 
 

hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs

@@ -13,6 +13,7 @@ import HBS2.Data.Types.SignedBox
 import HBS2.Net.Messaging.Unix
 import HBS2.Net.Messaging.Encrypted.ByPass (ByPassStat)
 import HBS2.Net.Proto.Service
+import HBS2.Peer.Proto.Mailbox
 import HBS2.Peer.RPC.Class
 import HBS2.Peer.Brains
 
@@ -27,18 +28,19 @@ import UnliftIO
 
 data RPC2Context =
   RPC2Context
-  { rpcConfig             :: [Syntax C]
+  { rpcConfig              :: [Syntax C]
-  , rpcMessaging          :: MessagingUnix
+  , rpcMessaging           :: MessagingUnix
-  , rpcPokeAnswer         :: String
+  , rpcPokeAnswer          :: String
-  , rpcPeerEnv            :: PeerEnv L4Proto
+  , rpcPeerEnv             :: PeerEnv L4Proto
-  , rpcLocalMultiCast     :: Peer L4Proto
+  , rpcLocalMultiCast      :: Peer L4Proto
-  , rpcStorage            :: AnyStorage
+  , rpcStorage             :: AnyStorage
-  , rpcBrains             :: SomeBrains L4Proto
+  , rpcBrains              :: SomeBrains L4Proto
-  , rpcByPassInfo         :: IO ByPassStat
+  , rpcByPassInfo          :: IO ByPassStat
-  , rpcDoFetch            :: HashRef -> IO ()
+  , rpcDoFetch             :: HashRef -> IO ()
-  , rpcDoRefChanHeadPost  :: HashRef -> IO ()
+  , rpcDoRefChanHeadPost   :: HashRef -> IO ()
-  , rpcDoRefChanPropose   :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
+  , rpcDoRefChanPropose    :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
-  , rpcDoRefChanNotify    :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
+  , rpcDoRefChanNotify     :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
+  , rpcMailboxService      :: AnyMailboxService (Encryption L4Proto)
   }
 
 instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where