Mailbox CLI and RPC boilerplate

hbs2-peer/app/CLI/Mailbox.hs

@@ -0,0 +1,77 @@
+module CLI.Mailbox (pMailBox) where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Net.Proto.Service
+import HBS2.Net.Auth.Credentials
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto.LWWRef
+
+import HBS2.Peer.RPC.API.Mailbox
+import HBS2.KeyMan.Keys.Direct
+
+import CLI.Common
+import RPC2()
+import PeerLogger hiding (info)
+
+import Data.Config.Suckless.Script
+
+import System.Exit
+import System.Environment (lookupEnv)
+
+import Control.Monad.Trans.Cont
+import Options.Applicative
+import Data.Maybe
+
+import Data.Word
+import Lens.Micro.Platform
+
+
+pMailBox :: Parser (IO ())
+pMailBox = do
+ rpc <- pRpcCommon
+ what <- many (strArgument (metavar "ARGS" <> help "hbs2-cli mailbox command-line"))
+ pure (runMailboxCLI rpc what)
+
+runMailboxCLI :: RPCOpt -> [String] -> IO ()
+runMailboxCLI rpc s = do
+
+  cli <- parseTop (unwords s) & either (error.show) pure
+
+  let t = TimeoutSec 1
+
+  let dict api = makeDict @C do
+        entry $ bindMatch "hey" $ nil_ $ const do
+          who <- liftIO (lookupEnv "USER") <&> fromMaybe "stranger"
+          liftIO $ print $ "hey," <+> pretty who
+
+        entry $ bindMatch "poke" $ nil_ $ const do
+          _ <- callRpcWaitMay @RpcMailboxPoke t api ()
+                 >>= orThrowUser "rpc call timeout"
+
+          liftIO $ print $ pretty "okay, rpc is here"
+
+        entry $ bindMatch "create" $ nil_ $ const do
+          warn "mailbox create is not here yet"
+          -- TODO: mailbox-create
+          --  - [ ] answer: via RPC or direct
+          --  - [ ] answer: peer state or separate database (separate)
+          --  - [ ] implement: MailboxWorker
+          --  - [ ] implement: interwire MailboxWorker and mailboxProto
+
+        entry $ bindMatch "help" $ nil_ \case
+          HelpEntryBound what -> helpEntry what
+          [StringLike s]      -> helpList False (Just s)
+          _                   -> helpList False Nothing
+
+  flip runContT pure do
+
+    caller <- ContT $ withMyRPC @MailboxAPI rpc
+    lift $ run (dict caller) cli >>= eatNil display
+
+  -- withMyRPC @LWWRefAPI rpc $ \caller -> do
+  --   callService @RpcLWWRefGet caller ref >>= \case
+  --     Left e  -> err (viaShow e) >> exitFailure
+  --     Right r -> print $ pretty r
+
+

hbs2-peer/app/PeerMain.hs

@@ -60,6 +60,7 @@ import PeerMeta
 import CLI.Common
 import CLI.RefChan
 import CLI.LWWRef
+import CLI.Mailbox
 import RefChan
 import RefChanNotifyLog
 import Fetch (fetchHash)
@@ -74,6 +75,7 @@ import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.API.RefLog
 import HBS2.Peer.RPC.API.RefChan
 import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Peer.RPC.API.Mailbox
 import HBS2.Peer.Notify
 import HBS2.Peer.RPC.Client.StorageClient
 
@@ -246,6 +248,7 @@ runCLI = do
                 <> command "reflog"    (info pRefLog (progDesc "reflog commands"))
                 <> command "refchan"   (info pRefChan (progDesc "refchan commands"))
                 <> command "lwwref"    (info pLwwRef (progDesc "lwwref commands"))
+                <> command "mailbox"   (info pMailBox (progDesc "mailbox commands"))
                 <> command "peers"     (info pPeers (progDesc "show known peers"))
                 <> command "pexinfo"   (info pPexInfo (progDesc "show pex"))
                 <> command "download"  (info pDownload  (progDesc "download management"))
@@ -1229,6 +1232,7 @@ runPeer opts = Exception.handle (\e -> myException e
       , makeResponse (makeServer @RefChanAPI)
       , makeResponse (makeServer @StorageAPI)
       , makeResponse (makeServer @LWWRefAPI)
+      , makeResponse (makeServer @MailboxAPI)
       , makeResponse (makeNotifyServer @(RefChanEvents L4Proto) env)
       , makeResponse (makeNotifyServer @(RefLogEvents L4Proto) envrl)
       ]

hbs2-peer/app/RPC2.hs

@@ -3,6 +3,7 @@ module RPC2
   , module RPC2.RefLog
   , module RPC2.RefChan
   , module RPC2.LWWRef
+  , module RPC2.Mailbox
   ) where
 
 
@@ -10,4 +11,5 @@ import RPC2.Peer
 import RPC2.RefLog
 import RPC2.RefChan
 import RPC2.LWWRef
+import RPC2.Mailbox()
 

hbs2-peer/app/RPC2/Mailbox.hs

@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
+module RPC2.Mailbox where
+
+import HBS2.Peer.Prelude
+
+import HBS2.Actors.Peer
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto
+import HBS2.Peer.Proto.Mailbox
+import HBS2.Storage
+import HBS2.Net.Messaging.Unix
+import HBS2.Misc.PrettyStuff
+
+import PeerTypes
+
+import HBS2.Peer.RPC.Internal.Types
+import HBS2.Peer.RPC.API.Mailbox
+
+import Lens.Micro.Platform
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+
+
+instance (MonadIO m) => HandleMethod m RpcMailboxPoke where
+
+  handleMethod key = do
+    debug "rpc.RpcMailboxPoke"
+

hbs2-peer/hbs2-peer.cabal

@@ -176,6 +176,7 @@ library
       HBS2.Peer.RPC.API.RefLog
       HBS2.Peer.RPC.API.RefChan
       HBS2.Peer.RPC.API.LWWRef
+      HBS2.Peer.RPC.API.Mailbox
       HBS2.Peer.RPC.API.Storage
       HBS2.Peer.RPC.Client.Unix
       HBS2.Peer.RPC.Client.StorageClient
@@ -270,6 +271,7 @@ executable hbs2-peer
                     , RPC2.RefLog
                     , RPC2.RefChan
                     , RPC2.LWWRef
+                    , RPC2.Mailbox
                     , PeerTypes
                     , PeerLogger
                     , PeerConfig
@@ -284,6 +286,7 @@ executable hbs2-peer
                     , CLI.Common
                     , CLI.RefChan
                     , CLI.LWWRef
+                    , CLI.Mailbox
 
                     , Paths_hbs2_peer
 

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

@@ -0,0 +1,34 @@
+{-# Language UndecidableInstances #-}
+module HBS2.Peer.RPC.API.Mailbox where
+
+import HBS2.Peer.Prelude
+import HBS2.Net.Proto.Service
+import HBS2.Net.Messaging.Unix (UNIX)
+import HBS2.Data.Types.Refs (HashRef(..))
+import HBS2.Data.Types.SignedBox
+
+import Data.ByteString.Lazy ( ByteString )
+import Data.ByteString qualified as BS
+import Codec.Serialise
+
+data RpcMailboxPoke
+
+type MailboxAPI = '[ RpcMailboxPoke
+                   ]
+
+type MailboxAPIProto =  0x056091510d3b2ec9
+
+
+instance HasProtocol UNIX  (ServiceProto MailboxAPI UNIX) where
+  type instance ProtocolId (ServiceProto MailboxAPI UNIX) = MailboxAPIProto
+  type instance Encoded UNIX = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+
+type instance Input RpcMailboxPoke   = ()
+type instance Output RpcMailboxPoke  = ()
+
+
+
+
+