From de7886e4e3e4125c79588fe7e6e3858169cd097b Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Fri, 18 Oct 2024 07:52:39 +0300
Subject: [PATCH] wip, hbs2:mailbox:policy:basic:read:storage

---
 hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs | 19 +++++++++++--------
 hbs2-peer/app/MailboxProtoWorker.hs  |  2 +-
 2 files changed, 12 insertions(+), 9 deletions(-)

diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs
index b9a7f8b7..141cc9db 100644
--- a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs
+++ b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs
@@ -3,6 +3,7 @@ module HBS2.CLI.Run.Mailbox where
 
 import HBS2.CLI.Prelude
 import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.Merkle
 
 import HBS2.Net.Auth.GroupKeySymm
 import HBS2.Peer.Proto.Mailbox
@@ -14,6 +15,7 @@ import HBS2.Storage
 import HBS2.KeyMan.Keys.Direct as K
 
 import Codec.Serialise
+import Control.Monad.Except
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Lazy.Char8 qualified as LBS8
@@ -125,14 +127,15 @@ mailboxEntries = do
 
 
   entry $ bindMatch "hbs2:mailbox:policy:basic:read:storage" $ \case
-    [HashLike fn] -> lift do
-      error "FUCK"
-      -- what <- liftIO (readFile fn)
-      --          <&> parseTop
-      --          >>= either (error.show) pure
-      --          >>= parseBasicPolicy
-      --          >>= orThrowUser "invalid policy"
-      -- mkOpaque what
+    [HashLike href] -> lift do
+      sto <- getStorage
+      what <- runExceptT (getTreeContents sto href)
+                >>= orThrowPassIO
+                <&> parseTop . LBS8.unpack
+                >>= either (error.show) pure
+                >>= parseBasicPolicy
+                >>= orThrowUser "invalid policy"
+      mkOpaque what
 
     _ -> throwIO (BadFormException @c nil)
 
diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs
index 67a9962c..b36be154 100644
--- a/hbs2-peer/app/MailboxProtoWorker.hs
+++ b/hbs2-peer/app/MailboxProtoWorker.hs
@@ -911,7 +911,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
       -- FIXME: mailbox-check-period
       --   right now  it's 60 seconds for debug purposes
       --   remove hardcode to smth reasonable
-      let mboxes = liftIO (listMailboxes @s dbe <&> fmap (set _2 60) )
+      let mboxes = liftIO (listMailboxes @s dbe <&> fmap (set _2 600) )
 
       polling (Polling 10 10) mboxes $ \r -> do
         debug $ yellow "mailbox: SEND FETCH REQUEST FOR" <+> pretty r