mirror of https://github.com/voidlizard/hbs2
167 lines
5.2 KiB
Haskell
167 lines
5.2 KiB
Haskell
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
|
|
import HBS2.Peer.Proto.Mailbox.Policy.Basic
|
|
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Hash
|
|
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
|
|
import Data.Coerce
|
|
import Data.Either
|
|
|
|
createShortMessageFromByteString :: forall s m . ( MonadUnliftIO m
|
|
, s ~ HBS2Basic
|
|
, HasStorage m
|
|
)
|
|
=> LBS8.ByteString
|
|
-> m (Message s)
|
|
createShortMessageFromByteString lbs = do
|
|
let ls0 = LBS8.lines lbs
|
|
let (hbs, rest1) = break LBS8.null ls0
|
|
let payload = dropWhile LBS8.null rest1 & LBS8.unlines
|
|
let headers = parseTop (LBS8.unpack (LBS8.unlines hbs)) & fromRight mempty
|
|
|
|
flagz <- defMessageFlags
|
|
|
|
sender <- headMay [ Left s | ListVal [SymbolVal "sender:", HashLike s] <- headers ]
|
|
& orThrowUser "sender not defined"
|
|
|
|
let rcpts = [ Left s | ListVal [SymbolVal "recipient:", HashLike s] <- headers ]
|
|
|
|
sto <- getStorage
|
|
|
|
let cms = CreateMessageServices
|
|
sto
|
|
( runKeymanClientRO . loadCredentials )
|
|
( runKeymanClientRO . loadKeyRingEntry )
|
|
|
|
createMessage cms flagz Nothing sender rcpts mempty (LBS8.toStrict payload)
|
|
|
|
|
|
|
|
mailboxEntries :: forall c m . ( IsContext c
|
|
, MonadUnliftIO m
|
|
, HasStorage m
|
|
, Exception (BadFormException c)
|
|
) => MakeDictM c m ()
|
|
mailboxEntries = do
|
|
|
|
brief "creates a new object of Mailbox.Message from text"
|
|
$ args [arg "string" "filename"]
|
|
$ desc ""
|
|
$ returns "blob" "message"
|
|
$ entry $ bindMatch "hbs2:mailbox:message:create:short" $ \case
|
|
[StringLike fn] -> lift do
|
|
lbs <- liftIO $ LBS8.readFile fn
|
|
mess <- createShortMessageFromByteString lbs
|
|
mkOpaque (serialise mess)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:message:read:file" $ nil_ \case
|
|
[StringLike s] -> lift do
|
|
sto <- getStorage
|
|
let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret)
|
|
|
|
(s,_,bs) <- liftIO (LBS.readFile s)
|
|
<&> deserialiseOrFail @(Message HBS2Basic)
|
|
>>= orThrowUser "invalid message format"
|
|
>>= readMessage rms
|
|
|
|
liftIO $ BS.putStr bs
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:message:read:storage" $ nil_ \case
|
|
[HashLike h] -> lift do
|
|
sto <- getStorage
|
|
let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret)
|
|
|
|
(s,_,bs) <- getBlock sto (coerce h)
|
|
>>= orThrowUser "message not found"
|
|
<&> deserialiseOrFail @(Message HBS2Basic)
|
|
>>= orThrowUser "invalid message format"
|
|
>>= readMessage rms
|
|
|
|
liftIO $ BS.putStr bs
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:policy:basic:read:syntax" $ \case
|
|
[ListVal syn] -> do
|
|
po <- parseBasicPolicy syn >>= orThrowUser "malformed policy"
|
|
mkOpaque po
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
entry $ bindMatch "hbs2:mailbox:policy:basic:read:file" $ \case
|
|
[StringLike fn] -> lift do
|
|
|
|
what <- liftIO (readFile fn)
|
|
<&> parseTop
|
|
>>= either (error.show) pure
|
|
>>= parseBasicPolicy
|
|
>>= orThrowUser "invalid policy"
|
|
|
|
mkOpaque what
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:policy:basic:read:storage" $ \case
|
|
[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)
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:policy:basic:accept:peer" $ \case
|
|
[SignPubKeyLike who, OpaqueVal box] -> lift do
|
|
p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box
|
|
r <- policyAcceptPeer @HBS2Basic p who
|
|
pure $ mkBool @c r
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:policy:basic:accept:sender" $ \case
|
|
[SignPubKeyLike who, OpaqueVal box] -> lift do
|
|
p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box
|
|
r <- policyAcceptSender @HBS2Basic p who
|
|
pure $ mkBool @c r
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
entry $ bindMatch "hbs2:mailbox:policy:basic:dump" $ nil_ $ \case
|
|
[OpaqueVal box] -> lift do
|
|
p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box
|
|
liftIO $ print $ vcat (fmap pretty (getAsSyntax @c p))
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|