wip

hbs2-peer/app/CLI/Mailbox.hs

@@ -137,6 +137,19 @@ runMailboxCLI rpc s = do
 
              _ -> throwIO $ BadFormException @C nil
 
+        brief "get mailbox status"
+          $ entry $ bindMatch "status" $ nil_ $ \case
+             [ SignPubKeyLike m ] -> do
+
+              v <- callRpcWaitMay @RpcMailboxGetStatus t api m
+                     >>= orThrowUser "rpc call timeout"
+                     >>= orThrowPassIO
+
+              liftIO $ print $ pretty v
+
+             _ -> throwIO $ BadFormException @C nil
+
+
         brief "list mailboxes"
           $ entry $ bindMatch "list" $ nil_ $ const do
 

hbs2-peer/app/MailboxProtoWorker.hs

@@ -37,18 +37,19 @@ import BlockDownload()
 
 import DBPipe.SQLite
 
-import Control.Monad.Trans.Cont
-import Control.Monad.Trans.Maybe
-import Data.Maybe
-import UnliftIO
 import Control.Concurrent.STM qualified as STM
 -- import Control.Concurrent.STM.TBQueue
-import Data.HashMap.Strict qualified as HM
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Data.Coerce
 import Data.HashMap.Strict (HashMap)
-import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
 import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Maybe
 import Lens.Micro.Platform
 import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO
 
 data MailboxProtoException =
     MailboxProtoWorkerTerminatedException
@@ -68,6 +69,7 @@ data MailboxProtoWorker (s :: CryptoScheme) e =
   { mpwPeerEnv            :: PeerEnv e
   , mpwDownloadEnv        :: DownloadEnv e
   , mpwStorage            :: AnyStorage
+  , mpwCredentials        :: PeerCredentials s
   , inMessageQueue        :: TBQueue (Message s, MessageContent s)
   , inMessageMergeQueue   :: TVar (HashMap (MailboxRefKey s) (HashSet HashRef))
   , inMessageQueueInNum   :: TVar Int
@@ -78,6 +80,9 @@ data MailboxProtoWorker (s :: CryptoScheme) e =
   }
 
 instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where
+
+  mailboxGetCredentials = pure . mpwCredentials
+
   mailboxGetStorage = pure . mpwStorage
 
   mailboxAcceptMessage MailboxProtoWorker{..} m c = do
@@ -159,22 +164,39 @@ instance ( s ~ Encryption e, e ~ L4Proto
       pure $ Right r
 
   mailboxGetStatus MailboxProtoWorker{..} ref = do
-    undefined
+    -- TODO: support-policy-ASAP
 
-getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> Recipient s -> m (Maybe MailboxType)
+    now <- liftIO $ getPOSIXTime <&> round
+
+    flip runContT pure do
+
+      mdbe <- readTVarIO mailboxDB
+
+      dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready"))
+
+      t' <- getMailboxType_ dbe ref
+
+      t <- ContT $ maybe1 t' (pure $ Right Nothing)
+
+      v <- getRef mpwStorage ref <&> fmap HashRef
+
+      pure $ Right $ Just $ MailBoxStatusPayload @s now (coerce ref) t v mzero mzero
+
+getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> MailboxRefKey s -> m (Maybe MailboxType)
 getMailboxType_ d r = do
   let sql = [qc|select type from mailbox where recipient = ? limit 1|]
   withDB d do
-   select @(Only String) sql (Only (show $ pretty (AsBase58 r)))
+   select @(Only String) sql (Only r)
      <&> fmap (fromStringMay @MailboxType  . fromOnly)
      <&> headMay . catMaybes
 
 createMailboxProtoWorker :: forall s e m . (MonadIO m, s ~ Encryption e, ForMailbox s)
-                         => PeerEnv e
+                         => PeerCredentials s
+                         -> PeerEnv e
                          -> DownloadEnv e
                          -> AnyStorage
                          -> m (MailboxProtoWorker s e)
-createMailboxProtoWorker pe de sto = do
+createMailboxProtoWorker pc pe de sto = do
   -- FIXME: queue-size-hardcode
   --   $class: hardcode
   inQ        <- newTBQueueIO 1000
@@ -184,7 +206,7 @@ createMailboxProtoWorker pe de sto = do
   outNum     <- newTVarIO 0
   decl       <- newTVarIO 0
   dbe        <- newTVarIO Nothing
-  pure $ MailboxProtoWorker pe de sto inQ mergeQ inNum outNum inDroppped decl dbe
+  pure $ MailboxProtoWorker pe de sto pc inQ mergeQ inNum outNum inDroppped decl dbe
 
 mailboxProtoWorker :: forall e s m . ( MonadIO m
                                      , MonadUnliftIO m
@@ -243,7 +265,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
           -- TODO: process-with-policy
 
           for_ (messageRecipients s) $ \rcpt -> void $ runMaybeT do
-            mbox <- getMailboxType_ @s dbe rcpt
+            mbox <- getMailboxType_ @s dbe (MailboxRefKey rcpt)
                        >>= toMPlus
 
             -- TODO: ASAP-block-accounting

hbs2-peer/app/PeerMain.hs

@@ -902,7 +902,7 @@ runPeer opts = Exception.handle (\e -> myException e
 
   rcw <- async $ liftIO $ runRefChanRelyWorker rce refChanAdapter
 
-  mailboxWorker <- createMailboxProtoWorker  penv denv (AnyStorage s)
+  mailboxWorker <- createMailboxProtoWorker pc  penv denv (AnyStorage s)
 
   let onNoBlock (p, h) = do
         already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust

hbs2-peer/app/RPC2/Mailbox.hs

@@ -11,6 +11,8 @@ import HBS2.Data.Types.SignedBox
 import HBS2.Peer.Proto
 import HBS2.Peer.Proto.Mailbox
 import HBS2.Peer.Proto.Mailbox.Ref
+import HBS2.Peer.Proto.Mailbox.Types
+
 import HBS2.Storage
 import HBS2.Net.Messaging.Unix
 import HBS2.Misc.PrettyStuff
@@ -45,6 +47,14 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where
     void $ mailboxCreate @HBS2Basic mbs t puk
     debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t
 
+
+instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGetStatus where
+
+  handleMethod puk = do
+    AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService
+    debug $ "rpc.RpcMailboxGetStatus" <+> pretty (AsBase58 puk)
+    mailboxGetStatus @HBS2Basic mbs (MailboxRefKey puk)
+
 instance (ForMailboxRPC m) => HandleMethod m RpcMailboxDelete where
 
   handleMethod puk = do

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

@@ -10,23 +10,29 @@ module HBS2.Peer.Proto.Mailbox
 import HBS2.Prelude.Plated
 
 import HBS2.Hash
+import HBS2.Base58
 import HBS2.Data.Types.Refs
 import HBS2.Data.Types.SignedBox
 import HBS2.Storage
 import HBS2.Actors.Peer.Types
+import HBS2.Net.Auth.Credentials
 
 import HBS2.Peer.Proto.Mailbox.Types
 import HBS2.Peer.Proto.Mailbox.Message
 import HBS2.Peer.Proto.Mailbox.Entry
 import HBS2.Peer.Proto.Mailbox.Ref
 
-import Data.Maybe
-import Control.Monad.Trans.Cont
 import Codec.Serialise()
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Data.Maybe
+import Data.Word
+import Lens.Micro.Platform
 
 data MailBoxStatusPayload s =
   MailBoxStatusPayload
-  { mbsMailboxKey           :: MailboxKey s
+  { mbsMailboxPayloadNonce  :: Word64
+  , mbsMailboxKey           :: MailboxKey s
   , mbsMailboxType          :: MailboxType
   , mbsMailboxHash          :: Maybe HashRef
   , mbsMailboxPolicyVersion :: Maybe PolicyVersion
@@ -69,6 +75,8 @@ instance ForMailbox s => Serialise (MailBoxProto s e)
 
 class IsMailboxProtoAdapter s a where
 
+  mailboxGetCredentials :: forall m . MonadIO m => a -> m (PeerCredentials s)
+
   mailboxGetStorage     :: forall m . MonadIO m => a -> m AnyStorage
 
   mailboxAcceptMessage  :: forall m . (ForMailbox s, MonadIO m)
@@ -77,10 +85,6 @@ class IsMailboxProtoAdapter s a where
                         -> MessageContent s
                         -> m ()
 
-data MailboxServiceError =
-  MailboxCreateFailed String
-  deriving stock (Typeable,Show)
-
 
 class ForMailbox s => IsMailboxService s a where
 
@@ -132,9 +136,26 @@ instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where
   mailboxGetStatus (AnyMailboxService a) = mailboxGetStatus @s a
 
 instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
+  mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @s a
   mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a
   mailboxAcceptMessage (AnyMailboxAdapter a) = mailboxAcceptMessage @s a
 
+instance ForMailbox s => Pretty (MailBoxStatusPayload s) where
+  pretty MailBoxStatusPayload{..} =
+    parens $ "mailbox-status" <> line <> st
+    where
+      st = indent 2 $
+             brackets $
+             vcat [ parens ("nonce" <+> pretty mbsMailboxPayloadNonce)
+                  , parens ("key"   <+> pretty (AsBase58 mbsMailboxKey))
+                  , parens ("type"  <+> pretty mbsMailboxType)
+                  , element "mailbox-tree"   mbsMailboxHash
+                  , element "policy-version" mbsMailboxPolicyVersion
+                  , element "policy-tree"    mbsMailboxPolicyHash
+                  ]
+
+      element el = maybe mempty ( \v -> parens (el <+> pretty v) )
+
 mailboxProto :: forall e s m p a . ( MonadIO m
                                    , Response e p m
                                    , HasDeferred p e m
@@ -228,10 +249,20 @@ mailboxProto inner adapter mess = deferred @p do
     --        и так и известен в протоколе)
     --
 
-    CheckMailbox k -> do
+    CheckMailbox k -> deferred @p do
+      creds <- mailboxGetCredentials @s adapter
+
+      void $ runMaybeT do
+
       -- TODO: check-policy
 
-      none
+        s <- mailboxGetStatus adapter (MailboxRefKey @s k)
+               >>= toMPlus
+               >>= toMPlus
+
+        let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s
+
+        lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box))
 
     MailboxStatus{} -> do
       -- TODO: implement-MailboxStatus
@@ -253,4 +284,3 @@ mailboxProto inner adapter mess = deferred @p do
       none
 
 
-

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

@@ -4,6 +4,7 @@ module HBS2.Peer.Proto.Mailbox.Types
   ( ForMailbox
   , MailboxKey
   , MailboxType(..)
+  , MailboxServiceError(..)
   , Recipient
   , Sender
   , PolicyVersion
@@ -26,6 +27,14 @@ import HBS2.Net.Auth.GroupKeySymm
 import Data.Word (Word32)
 import Codec.Serialise
 import Data.Maybe
+import Control.Exception
+
+data MailboxServiceError =
+  MailboxCreateFailed String
+  deriving stock (Typeable,Show,Generic)
+
+instance Serialise MailboxServiceError
+instance Exception MailboxServiceError
 
 data MailboxType =
   MailboxHub | MailboxRelay

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

@@ -17,6 +17,7 @@ import Codec.Serialise
 data RpcMailboxPoke
 data RpcMailboxCreate
 data RpcMailboxDelete
+data RpcMailboxGetStatus
 data RpcMailboxList
 data RpcMailboxSend
 data RpcMailboxGet
@@ -24,6 +25,7 @@ data RpcMailboxGet
 type MailboxAPI = '[ RpcMailboxPoke
                    , RpcMailboxCreate
                    , RpcMailboxDelete
+                   , RpcMailboxGetStatus
                    , RpcMailboxList
                    , RpcMailboxSend
                    , RpcMailboxGet
@@ -47,6 +49,10 @@ type instance Output RpcMailboxCreate  = ()
 type instance Input RpcMailboxDelete   = (PubKey 'Sign HBS2Basic)
 type instance Output RpcMailboxDelete  = ()
 
+
+type instance Input RpcMailboxGetStatus  = (PubKey 'Sign HBS2Basic)
+type instance Output RpcMailboxGetStatus = Either MailboxServiceError (Maybe (MailBoxStatusPayload 'HBS2Basic))
+
 type instance Input RpcMailboxList   = ()
 type instance Output RpcMailboxList  = [(MailboxRefKey 'HBS2Basic, MailboxType)]