diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs index 8201388f..5ec3954e 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs +++ b/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 ) diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs index c3c01171..a663ea94 100644 --- a/hbs2-peer/app/CLI/Mailbox.hs +++ b/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 - 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 + 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) + +|] + $ 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 diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index f42aebe8..6bab1b3f 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/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) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 4e874521..9b4176e4 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs index 8c56931d..c9dac8ce 100644 --- a/hbs2-peer/app/RPC2/Mailbox.hs +++ b/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 + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index c34c560d..9372c12c 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs index 9df3ce1d..45c9c5a9 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs +++ b/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 + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs index bc3320a5..977e8a66 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs +++ b/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 = () diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index f35a6cee..65d88d23 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/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] - , rpcMessaging :: MessagingUnix - , rpcPokeAnswer :: String - , rpcPeerEnv :: PeerEnv L4Proto - , rpcLocalMultiCast :: Peer L4Proto - , rpcStorage :: AnyStorage - , rpcBrains :: SomeBrains L4Proto - , rpcByPassInfo :: IO ByPassStat - , rpcDoFetch :: HashRef -> IO () - , rpcDoRefChanHeadPost :: HashRef -> IO () - , rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () - , rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () + { rpcConfig :: [Syntax C] + , rpcMessaging :: MessagingUnix + , rpcPokeAnswer :: String + , rpcPeerEnv :: PeerEnv L4Proto + , rpcLocalMultiCast :: Peer L4Proto + , rpcStorage :: AnyStorage + , rpcBrains :: SomeBrains L4Proto + , rpcByPassInfo :: IO ByPassStat + , rpcDoFetch :: HashRef -> IO () + , rpcDoRefChanHeadPost :: HashRef -> IO () + , rpcDoRefChanPropose :: (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