From f2b8bc15179bb4b35f9f8de27ee0f62763c5d8ad Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Wed, 9 Oct 2024 09:56:54 +0300
Subject: [PATCH] basic mailbox creation

---
 hbs2-peer/app/CLI/Mailbox.hs             |  4 ++--
 hbs2-peer/app/MailboxProtoWorker.hs      | 20 ++++++++++++++++++--
 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs |  2 +-
 3 files changed, 21 insertions(+), 5 deletions(-)

diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs
index a663ea94..e907c9da 100644
--- a/hbs2-peer/app/CLI/Mailbox.hs
+++ b/hbs2-peer/app/CLI/Mailbox.hs
@@ -104,10 +104,10 @@ see hbs2-cli for sigil commands (create, store, load, etc)
               case syn of
                 [ StringLike "--key", SignPubKeyLike puk, MailboxTypeLike tp ] -> do
 
-                  _ <- callRpcWaitMay @RpcMailboxCreate t api (puk, tp)
+                  r <- callRpcWaitMay @RpcMailboxCreate t api (puk, tp)
                          >>= orThrowUser "rpc call timeout"
 
-                  liftIO $ print $ pretty "done"
+                  liftIO $ print $ viaShow r
 
                 [ StringLike "--sigil", HashLike sh, StringLike tp ] -> do
                   -- TODO: implement-create-by-sigil
diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs
index 6bab1b3f..9ece0952 100644
--- a/hbs2-peer/app/MailboxProtoWorker.hs
+++ b/hbs2-peer/app/MailboxProtoWorker.hs
@@ -68,9 +68,25 @@ instance (s ~ HBS2Basic) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) whe
         writeTBQueue inMessageQueue (m,c)
 
 instance (s ~ HBS2Basic) => IsMailboxService s (MailboxProtoWorker s e) where
-  mailboxCreate _ t p = do
+  mailboxCreate MailboxProtoWorker{..} t p = do
     debug $ "mailboxWorker.mailboxCreate" <+> pretty (AsBase58 p) <+> pretty t
-    pure $ Right ()
+
+    flip runContT pure $ callCC \exit -> do
+
+      mdbe <- readTVarIO mailboxDB
+
+      dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready"))
+
+      r <- liftIO $ try @_ @SomeException $ withDB dbe do
+             insert [qc|
+             insert into mailbox (recipient,type)
+             values (?,?)
+             on conflict (recipient) do nothing
+                       |] (show $ pretty $ AsBase58 p, show $ pretty t)
+
+      case r of
+        Right{} -> pure $ Right ()
+        Left{}  -> pure $ Left (MailboxCreateFailed "database operation")
 
 createMailboxProtoWorker :: forall e m . MonadIO m
                          => AnyStorage
diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs
index 9372c12c..2836cf27 100644
--- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs
+++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs
@@ -83,7 +83,7 @@ class IsMailboxProtoAdapter s a where
                         -> m ()
 
 data MailboxServiceError =
-  MailboxCreateFailed
+  MailboxCreateFailed String
   deriving stock (Typeable,Show)
 
 class IsMailboxService s a where