voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, hbs2📫policy:basic:read:storage

This commit is contained in:
voidlizard 2024-10-18 07:52:39 +03:00
parent 3fc740099e
commit de7886e4e3
2 changed files with 12 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs
View File

@ -3,6 +3,7 @@ module HBS2.CLI.Run.Mailbox where
import HBS2.CLI.Prelude import HBS2.CLI.Prelude
import HBS2.CLI.Run.Internal import HBS2.CLI.Run.Internal
import HBS2.CLI.Run.Internal.Merkle
import HBS2.Net.Auth.GroupKeySymm import HBS2.Net.Auth.GroupKeySymm
import HBS2.Peer.Proto.Mailbox import HBS2.Peer.Proto.Mailbox
@ -14,6 +15,7 @@ import HBS2.Storage
import HBS2.KeyMan.Keys.Direct as K import HBS2.KeyMan.Keys.Direct as K
import Codec.Serialise import Codec.Serialise
import Control.Monad.Except
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Lazy.Char8 qualified as LBS8
@ -125,14 +127,15 @@ mailboxEntries = do
entry $ bindMatch "hbs2:mailbox:policy:basic:read:storage" $ \case entry $ bindMatch "hbs2:mailbox:policy:basic:read:storage" $ \case
[HashLike fn] -> lift do [HashLike href] -> lift do
error "FUCK" sto <- getStorage
-- what <- liftIO (readFile fn) what <- runExceptT (getTreeContents sto href)
-- <&> parseTop >>= orThrowPassIO
-- >>= either (error.show) pure <&> parseTop . LBS8.unpack
-- >>= parseBasicPolicy >>= either (error.show) pure
-- >>= orThrowUser "invalid policy" >>= parseBasicPolicy
-- mkOpaque what >>= orThrowUser "invalid policy"
mkOpaque what
_ -> throwIO (BadFormException @c nil) _ -> throwIO (BadFormException @c nil)

2
hbs2-peer/app/MailboxProtoWorker.hs
View File

@ -911,7 +911,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
-- FIXME: mailbox-check-period -- FIXME: mailbox-check-period
-- right now it's 60 seconds for debug purposes -- right now it's 60 seconds for debug purposes
-- remove hardcode to smth reasonable -- 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 polling (Polling 10 10) mboxes $ \r -> do
debug $ yellow "mailbox: SEND FETCH REQUEST FOR" <+> pretty r debug $ yellow "mailbox: SEND FETCH REQUEST FOR" <+> pretty r