diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs new file mode 100644 index 00000000..c7398419 --- /dev/null +++ b/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 + + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 182f253c..9498165f 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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) ] diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index e9e10db9..dd1c9e6d 100644 --- a/hbs2-peer/app/RPC2.hs +++ b/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() diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs new file mode 100644 index 00000000..8c56931d --- /dev/null +++ b/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" + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 070ce148..4f8e2451 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs new file mode 100644 index 00000000..bc3320a5 --- /dev/null +++ b/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 = () + + + + +