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

set policy for mailbox

This commit is contained in:
voidlizard 2024-10-12 11:10:48 +03:00
parent 6962b7412e
commit d3d295d599
9 changed files with 275 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.fixme-new/config
View File

@ -50,7 +50,7 @@ fixme-comments ";" "--"
(align 8 $class) " "
(align 12 $assigned) " "
(align 20 (trim 20 $committer-name)) " "
(trim 50 ($fixme-title)) " "
(trim 40 ($fixme-title)) " "
(nl))
)
)

4
hbs2-core/lib/HBS2/Net/Proto.hs
View File

@ -6,9 +6,5 @@ module HBS2.Net.Proto
import HBS2.Hash
import HBS2.Net.Proto.Types
dontHandle :: Applicative f => a -> f ()
dontHandle = const $ pure ()
type GetBlockSize h m = Hash h -> m (Maybe Integer)

6
hbs2-core/lib/HBS2/Prelude.hs
View File

@ -28,6 +28,7 @@ module HBS2.Prelude
, HasErrorStatus(..), ErrorStatus(..), SomeError(..), WithSomeError(..), mayE, someE
, ByFirst(..)
, whenTrue, whenFalse
, dontHandle
) where
import HBS2.Clock
@ -174,11 +175,10 @@ instance Eq a => Eq (ByFirst a b) where
instance Hashable a => Hashable (ByFirst a b) where
hashWithSalt s (ByFirst a _) = hashWithSalt s a
dontHandle :: Applicative f => a -> f ()
dontHandle = const $ pure ()
-- asyncLinked :: forall m . MonadUnliftIO m =>

66
hbs2-peer/app/CLI/Mailbox.hs
View File

@ -3,6 +3,7 @@
module CLI.Mailbox (pMailBox) where
import HBS2.Prelude.Plated
import HBS2.Base58
import HBS2.Hash
import HBS2.OrDie
import HBS2.Merkle
@ -10,6 +11,7 @@ import HBS2.Data.Types.Refs
import HBS2.Net.Proto.Service
import HBS2.Net.Auth.Credentials
import HBS2.Storage
import HBS2.Storage.Operations.ByteString
import HBS2.Data.Types.SignedBox
import HBS2.Peer.Proto.Mailbox
import HBS2.Peer.Proto.Mailbox.Types
@ -28,6 +30,8 @@ import Codec.Serialise
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.Either
import Data.Coerce
import Data.Config.Suckless.Script
import Data.HashSet (HashSet)
@ -150,6 +154,59 @@ runMailboxCLI rpc s = do
_ -> throwIO $ BadFormException @C nil
brief "set mailbox policy" $
desc setPolicyDesc
-- $ examples setPolicyExamples
$ entry $ bindMatch "set-policy" $ nil_ $ \case
[ SignPubKeyLike m, LitIntVal v, StringLike fn ] -> lift do
mstatus <- callRpcWaitMay @RpcMailboxGetStatus t api m
>>= orThrowUser "rpc call timeout"
>>= orThrowPassIO
s <- liftIO $ readFile fn
<&> parseTop
>>= either (error . show) pure
pv <- fromMaybe 0 <$> runMaybeT do
MailBoxStatusPayload{..} <- toMPlus mstatus
pbox <- toMPlus mbsMailboxPolicy
(who, SetPolicyPayload{..}) <- unboxSignedBox0 pbox & toMPlus
guard ( m == who )
pure sppPolicyVersion
-- TODO: validate-policy
creds <- runKeymanClientRO (loadCredentials m)
>>= orThrowUser ("can't load credentials for" <+> pretty (AsBase58 m))
let normalized = show $ vcat (fmap pretty s)
notice $ "policy" <> line <> pretty normalized
notice $ "okay" <+> pretty pv <+> "->" <+> pretty v <+> pretty fn
hash <- writeAsMerkle sto (LBS8.pack normalized)
notice $ "stored policy as" <+> pretty hash
let spp = SetPolicyPayload @HBS2Basic m (fromIntegral v) (HashRef hash)
let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) spp
notice $ "signed policy payload done okay"
r <- callRpcWaitMay @RpcMailboxSetPolicy t api (m,box)
>>= orThrowUser "rpc call timeout"
>>= orThrowPassIO
liftIO $ print $ pretty r
_ -> throwIO $ BadFormException @C nil
brief "list mailboxes"
$ entry $ bindMatch "list" $ nil_ $ const do
@ -283,3 +340,12 @@ SEE ALSO
|]
setPolicyDesc :: Doc a
setPolicyDesc = [qc|
set-policy (MAILBOX-KEY :: PUBKEY) (VERSION :: INT) FILENAME
|]
setPolicyExamples :: ManExamples
setPolicyExamples = mempty

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

@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language MultiWayIf #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-}
module MailboxProtoWorker ( mailboxProtoWorker
@ -20,6 +21,7 @@ import HBS2.Storage
import HBS2.Storage.Operations.Missed
import HBS2.Merkle
import HBS2.Hash
import HBS2.Data.Types.SignedBox
import HBS2.Peer.Proto
import HBS2.Peer.Proto.Mailbox
import HBS2.Peer.Proto.Mailbox.Entry
@ -35,22 +37,34 @@ import PeerConfig
import PeerTypes
import BlockDownload()
import DBPipe.SQLite
import DBPipe.SQLite as Q
import Control.Concurrent.STM qualified as STM
-- import Control.Concurrent.STM.TBQueue
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except
import Control.Monad.Except (throwError)
import Data.Coerce
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.Maybe
import Codec.Serialise
import Lens.Micro.Platform
import Text.InterpolatedString.Perl6 (qc)
import UnliftIO
newtype PolicyHash = PolicyHash HashRef
deriving newtype (Eq,Ord,Show,Hashable,Pretty)
instance FromField PolicyHash where
fromField s = PolicyHash . fromString <$> fromField @String s
instance ToField PolicyHash where
toField f = toField (show $ pretty f)
data MailboxProtoException =
MailboxProtoWorkerTerminatedException
| MailboxProtoCantAccessMailboxes FilePath
@ -116,9 +130,54 @@ instance ( s ~ Encryption e, e ~ L4Proto
Right{} -> pure $ Right ()
Left{} -> pure $ Left (MailboxCreateFailed "database operation")
mailboxSetPolicy MailboxProtoWorker{..} sbox = do
-- check policy version
-- check policy has peers
-- write policy block
-- update reference to policy block
--
-- test: write policy, check mailboxGetStatus
debug $ red "mailboxSetPolicy"
runExceptT do
-- check policy signature
(who, spp) <- unboxSignedBox0 sbox
& orThrowError (MailboxAuthError "invalid signature")
dbe <- readTVarIO mailboxDB
>>= orThrowError (MailboxSetPolicyFailed "database not ready")
loaded <- loadPolicyPayloadFor dbe mpwStorage (MailboxRefKey @s who)
<&> fmap ( unboxSignedBox0 @(SetPolicyPayload s) @s . snd )
<&> join
what <- case loaded of
Nothing -> do
err $ red "mailboxSetPolicy FUCKED"
putBlock mpwStorage (serialise sbox)
>>= orThrowError (MailboxSetPolicyFailed "storage error")
<&> HashRef
Just (k, spp0) | sppPolicyVersion spp > sppPolicyVersion spp0 || k /= who -> do
putBlock mpwStorage (serialise sbox)
>>= orThrowError (MailboxSetPolicyFailed "storage error")
<&> HashRef
_ -> do
throwError (MailboxSetPolicyFailed "too old")
liftIO $ withDB dbe $ Q.transactional do
insert [qc| insert into policy (mailbox,hash) values(?,?)
on conflict (mailbox) do update set hash = excluded.hash
|] (MailboxRefKey @s who, PolicyHash what)
pure what
mailboxDelete MailboxProtoWorker{..} mbox = do
flip runContT pure $ callCC \exit -> do
flip runContT pure do
mdbe <- readTVarIO mailboxDB
@ -163,6 +222,11 @@ instance ( s ~ Encryption e, e ~ L4Proto
pure $ Right r
mailboxAcceptStatus MailboxProtoWorker{..} ref who MailBoxStatusPayload{..} = do
-- TODO: implement-policy-first
-- итак, мы не можем двигаться, пока не будет реализована policy.
pure $ Right ()
mailboxGetStatus MailboxProtoWorker{..} ref = do
-- TODO: support-policy-ASAP
@ -180,7 +244,30 @@ instance ( s ~ Encryption e, e ~ L4Proto
v <- getRef mpwStorage ref <&> fmap HashRef
pure $ Right $ Just $ MailBoxStatusPayload @s now (coerce ref) t v mzero mzero
spp <- loadPolicyPayloadFor dbe mpwStorage ref
<&> fmap snd
pure $ Right $ Just $ MailBoxStatusPayload @s now (coerce ref) t v spp
loadPolicyPayloadFor :: forall s m . (ForMailbox s, MonadIO m)
=> DBPipeEnv
-> AnyStorage
-> MailboxRefKey s
-> m (Maybe (HashRef, SignedBox (SetPolicyPayload s) s))
loadPolicyPayloadFor dbe sto who = do
phash <- withDB dbe do
select @(Only PolicyHash) [qc|select hash from policy where mailbox = ?|] (Only who)
<&> fmap (coerce @_ @HashRef . fromOnly)
<&> headMay
runMaybeT do
ha <- toMPlus phash
what <- getBlock sto (coerce ha)
>>= toMPlus
<&> deserialiseOrFail
>>= toMPlus
pure (ha, what)
getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> MailboxRefKey s -> m (Maybe MailboxType)
getMailboxType_ d r = do
@ -316,7 +403,10 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
-- NOTE: reliability
-- в случае отказа сторейджа все эти сообщения будут потеряны
-- однако, ввиду дублирования -- они рано или поздно будут
-- восстановлены с других реплик, если таковые имеются
-- восстановлены с других реплик, если таковые имеются.
--
-- Кроме того, мы можем писать WAL.
--
newTx <- atomically do
n <- readTVar inMessageMergeQueue
<&> fromMaybe mempty . HM.lookup r
@ -363,7 +453,7 @@ mailboxStateEvolve readConf MailboxProtoWorker{..} = do
atomically $ writeTVar mailboxDB (Just dbe)
withDB dbe do
withDB dbe $ Q.transactional do
ddl [qc|create table if not exists
mailbox ( recipient text not null
, type text not null
@ -371,6 +461,13 @@ mailboxStateEvolve readConf MailboxProtoWorker{..} = do
)
|]
ddl [qc|create table if not exists
policy ( mailbox text not null
, hash text not null
, primary key (mailbox)
)
|]
pure dbe

6
hbs2-peer/app/RPC2/Mailbox.hs
View File

@ -47,6 +47,12 @@ 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 RpcMailboxSetPolicy where
handleMethod (puk, sbox) = do
AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService
debug $ "rpc.RpcMailboxSetPolicy" <+> pretty (AsBase58 puk)
mailboxSetPolicy @HBS2Basic mbs sbox
instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGetStatus where

130
hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs
View File

@ -15,8 +15,12 @@ import HBS2.Data.Types.Refs
import HBS2.Data.Types.SignedBox
import HBS2.Storage
import HBS2.Actors.Peer.Types
import HBS2.Data.Types.Peer
import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Sessions
import HBS2.Peer.Proto.Peer
import HBS2.Peer.Proto.Mailbox.Types
import HBS2.Peer.Proto.Mailbox.Message
import HBS2.Peer.Proto.Mailbox.Entry
@ -29,22 +33,21 @@ import Data.Maybe
import Data.Word
import Lens.Micro.Platform
data SetPolicyPayload s =
SetPolicyPayload
{ sppMailboxKey :: MailboxKey s
, sppPolicyVersion :: PolicyVersion
, sppPolicyRef :: HashRef -- ^ merkle tree hash of policy description file
}
deriving stock (Generic)
data MailBoxStatusPayload s =
MailBoxStatusPayload
{ mbsMailboxPayloadNonce :: Word64
, mbsMailboxKey :: MailboxKey s
, mbsMailboxType :: MailboxType
, mbsMailboxHash :: Maybe HashRef
, mbsMailboxPolicyVersion :: Maybe PolicyVersion
, mbsMailboxPolicyHash :: Maybe HashRef
}
deriving stock (Generic)
data SetPolicyPayload s =
SetPolicyPayload
{ sppMailboxKey :: MailboxKey s
, sppPolicyVersion :: PolicyVersion
, sppPolicyRef :: HashRef
, mbsMailboxPolicy :: Maybe (SignedBox (SetPolicyPayload s) s)
}
deriving stock (Generic)
@ -57,7 +60,7 @@ data DeleteMessagesPayload s =
data MailBoxProtoMessage s e =
SendMessage (Message s) -- already has signed box
| CheckMailbox (MailboxKey s)
| CheckMailbox (Maybe Word64) (MailboxKey s)
| MailboxStatus (SignedBox (MailBoxStatusPayload s) s) -- signed by peer
| SetPolicy (SignedBox (SetPolicyPayload s) s)
| DeleteMessages (SignedBox (DeleteMessagesPayload s) s)
@ -94,6 +97,11 @@ class ForMailbox s => IsMailboxService s a where
-> Recipient s
-> m (Either MailboxServiceError ())
mailboxSetPolicy :: forall m . MonadIO m
=> a
-> SignedBox (SetPolicyPayload s) s
-> m (Either MailboxServiceError HashRef)
mailboxDelete :: forall m . MonadIO m
=> a
-> Recipient s
@ -120,6 +128,12 @@ class ForMailbox s => IsMailboxService s a where
-> MailboxRefKey s
-> m (Either MailboxServiceError (Maybe (MailBoxStatusPayload s)))
mailboxAcceptStatus :: forall m . MonadIO m
=> a
-> MailboxRefKey s
-> PubKey 'Sign s -- ^ peer's key
-> MailBoxStatusPayload s
-> m (Either MailboxServiceError ())
data AnyMailboxService s =
forall a . (IsMailboxService s a) => AnyMailboxService { mailboxService :: a }
@ -129,11 +143,13 @@ data AnyMailboxAdapter s =
instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where
mailboxCreate (AnyMailboxService a) = mailboxCreate @s a
mailboxSetPolicy (AnyMailboxService a) = mailboxSetPolicy @s a
mailboxDelete (AnyMailboxService a) = mailboxDelete @s a
mailboxSendMessage (AnyMailboxService a) = mailboxSendMessage @s a
mailboxSendDelete (AnyMailboxService a) = mailboxSendDelete @s a
mailboxListBasic (AnyMailboxService a) = mailboxListBasic @s a
mailboxGetStatus (AnyMailboxService a) = mailboxGetStatus @s a
mailboxAcceptStatus (AnyMailboxService a) = mailboxAcceptStatus @s a
instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @s a
@ -146,22 +162,35 @@ instance ForMailbox s => Pretty (MailBoxStatusPayload s) where
where
st = indent 2 $
brackets $
vcat [ parens ("nonce" <+> pretty mbsMailboxPayloadNonce)
align $ 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 "set-policy-payload-hash" (HashRef . hashObject . serialise <$> mbsMailboxPolicy)
, maybe mempty pretty spp
]
element el = maybe mempty ( \v -> parens (el <+> pretty v) )
spp = mbsMailboxPolicy >>= unboxSignedBox0 <&> snd
instance ForMailbox s => Pretty (SetPolicyPayload s) where
pretty SetPolicyPayload{..} = parens ( "set-policy-payload" <> line <> indent 2 (brackets w) )
where
w = align $
vcat [ parens ( "version" <+> pretty sppPolicyVersion )
, parens ( "ref" <+> pretty sppPolicyRef )
]
mailboxProto :: forall e s m p a . ( MonadIO m
, Response e p m
, HasDeferred p e m
, HasGossip e p m
, IsMailboxProtoAdapter s a
, IsMailboxService s a
, Sessions e (KnownPeer e) m
, p ~ MailBoxProto s e
, s ~ Encryption e
, ForMailbox s
@ -174,23 +203,13 @@ mailboxProto :: forall e s m p a . ( MonadIO m
mailboxProto inner adapter mess = deferred @p do
-- common stuff
sto <- mailboxGetStorage @s adapter
now <- liftIO $ getPOSIXTime <&> round
sto <- mailboxGetStorage @s adapter
now <- liftIO $ getPOSIXTime <&> round
that <- thatPeer @p
se <- find (KnownPeerKey that) id
case mailBoxProtoPayload mess of
SendMessage msg -> deferred @p do
-- TODO: implement-SendMessage
-- [ ] check-if-mailbox-exists
-- [ ] check-message-signature
-- [ ] if-already-processed-then-skip
-- [ ] store-message-hash-block-with-ttl
-- [ ] if-message-to-this-mailbox-then store-message
-- [ ] gossip-message
-- проверяем, что еще не обрабатывали?
-- если обрабатывали -- то дропаем
-- что мы пишем в сторейдж?
-- кто потом это дропает?
flip runContT pure $ callCC \exit -> do
@ -249,7 +268,7 @@ mailboxProto inner adapter mess = deferred @p do
-- и так и известен в протоколе)
--
CheckMailbox k -> deferred @p do
CheckMailbox _ k -> deferred @p do
creds <- mailboxGetCredentials @s adapter
void $ runMaybeT do
@ -264,18 +283,47 @@ mailboxProto inner adapter mess = deferred @p do
lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box))
MailboxStatus{} -> do
-- TODO: implement-MailboxStatus
--
-- [ ] if-do-gossip-setting-then
-- [ ] gossip-MailboxStatus
--
-- [ ] check-signed-box-or-drop
-- [ ] if-client-has-mailbox-then
-- [ ] get-mailbox-status
-- [ ] answer-MailboxStatus
--
none
MailboxStatus box -> deferred @p do
flip runContT pure $ callCC \exit -> do
let r = unboxSignedBox0 @(MailBoxStatusPayload s) box
PeerData{..} <- ContT $ maybe1 se none
(who, content@MailBoxStatusPayload{..}) <- ContT $ maybe1 r none
unless ( who == _peerSignKey ) $ exit ()
-- FIXME: timeout-hardcode
-- может быть вообще не очень хорошо
-- авторизовываться по времени.
-- возможно, надо слать нонс в CheckMailbox
-- и тут его проверять
unless ( abs (now - mbsMailboxPayloadNonce) < 3 ) $ exit ()
-- NOTE: possible-poisoning-attack
-- левый пир генерирует merkle tree сообщений и посылает его.
-- чего он может добиться: добавить "валидных" сообщений, которых не было
-- в ящике изначально. (зашифрованных, подписанных).
--
-- можно рассылать спам, ведь каждое спам-сообщение
-- будет валидно.
-- мы не можем подписывать что-либо подписью владельца ящика,
-- ведь мы не владеем его ключом.
--
-- как бороться: в policy ограничивать число пиров, которые
-- могут отдавать статус и игнорировать статусы от прочих пиров.
--
-- другой вариант -- каким-то образом публикуется подтверждение
-- от автора, что пир X владеет почтовым ящиком R.
--
-- собственно, это и есть policy.
--
-- а вот policy мы как раз можем публиковать с подписью автора,
-- он участвует в процессе обновления policy.
void $ mailboxAcceptStatus adapter (MailboxRefKey mbsMailboxKey) who content
SetPolicy{} -> do
none

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

@ -30,7 +30,9 @@ import Data.Maybe
import Control.Exception
data MailboxServiceError =
MailboxCreateFailed String
MailboxCreateFailed String
| MailboxSetPolicyFailed String
| MailboxAuthError String
deriving stock (Typeable,Show,Generic)
instance Serialise MailboxServiceError

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

@ -16,6 +16,7 @@ import Codec.Serialise
data RpcMailboxPoke
data RpcMailboxCreate
data RpcMailboxSetPolicy
data RpcMailboxDelete
data RpcMailboxGetStatus
data RpcMailboxList
@ -24,6 +25,7 @@ data RpcMailboxGet
type MailboxAPI = '[ RpcMailboxPoke
, RpcMailboxCreate
, RpcMailboxSetPolicy
, RpcMailboxDelete
, RpcMailboxGetStatus
, RpcMailboxList
@ -46,10 +48,12 @@ type instance Output RpcMailboxPoke = ()
type instance Input RpcMailboxCreate = (PubKey 'Sign HBS2Basic, MailboxType)
type instance Output RpcMailboxCreate = ()
type instance Input RpcMailboxSetPolicy = (PubKey 'Sign HBS2Basic, SignedBox (SetPolicyPayload HBS2Basic) HBS2Basic)
type instance Output RpcMailboxSetPolicy = Either MailboxServiceError HashRef
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))