mirror of https://github.com/voidlizard/hbs2
147 lines
4.3 KiB
Haskell
147 lines
4.3 KiB
Haskell
module HBS2.CLI.Run.GroupKey where
|
|
|
|
import HBS2.CLI.Prelude hiding (mapMaybe)
|
|
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.System.Logger.Simple.ANSI as All
|
|
import HBS2.Storage.Operations.Class
|
|
import HBS2.Storage.Operations.ByteString
|
|
import HBS2.Base58
|
|
import Data.List qualified as L
|
|
import Data.Maybe
|
|
import HBS2.CLI.Run.Internal
|
|
import HBS2.CLI.Run.Internal.GroupKey as G
|
|
import HBS2.Net.Auth.GroupKeySymm as Symm
|
|
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.KeyMan.Keys.Direct
|
|
|
|
import Data.Text qualified as Text
|
|
import Data.ByteString.Lazy.Char8 as LBS8
|
|
import Data.ByteString.Lazy as LBS
|
|
import Data.ByteString.Char8 as BS8
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.HashSet qualified as HS
|
|
import Control.Monad.Trans.Cont
|
|
import Control.Monad.Except
|
|
import Codec.Serialise
|
|
import Lens.Micro.Platform
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
|
|
groupKeyEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
|
|
groupKeyEntries = do
|
|
|
|
entry $ bindMatch "hbs2:groupkey:load" $ \case
|
|
[StringLike s] -> do
|
|
flip runContT pure do
|
|
sto <- ContT withPeerStorage
|
|
|
|
gk <- runExceptT (readFromMerkle sto (SimpleKey (fromString s)))
|
|
>>= orThrowUser "can't load group key"
|
|
<&> deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic)
|
|
>>= orThrowUser "invalid group key"
|
|
|
|
pure $ mkStr (show $ pretty $ AsGroupKeyFile gk)
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
entry $ bindMatch "hbs2:groupkey:store" $ \case
|
|
[LitStrVal s] -> do
|
|
flip runContT pure do
|
|
|
|
let lbs = LBS8.pack (Text.unpack s)
|
|
gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
|
|
`orDie` "invalid group key"
|
|
|
|
sto <- ContT withPeerStorage
|
|
ha <- writeAsMerkle sto (serialise gk)
|
|
pure $ mkStr (show $ pretty ha)
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
-- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \
|
|
-- [list [remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8] \
|
|
-- [add . 5sJXsw7qhmq521hwhE67jYvrD6ZNVazc89rFwfWaQPyY]] ]
|
|
--
|
|
entry $ bindMatch "hbs2:groupkey:update" $ \case
|
|
[LitStrVal s, ListVal ins] -> do
|
|
|
|
flip runContT pure do
|
|
|
|
sto <- ContT withPeerStorage
|
|
|
|
let lbs = LBS8.pack (Text.unpack s)
|
|
gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
|
|
`orDie` "invalid group key"
|
|
|
|
gk1 <- lift $ modifyGroupKey gk ins
|
|
|
|
pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1)
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
|
|
case syn of
|
|
[ListVal (StringLikeList keys)] -> do
|
|
s <- groupKeyFromKeyList keys
|
|
<&> AsGroupKeyFile
|
|
<&> show . pretty
|
|
|
|
pure $ mkStr s
|
|
|
|
StringLikeList keys -> do
|
|
s <- groupKeyFromKeyList keys
|
|
<&> AsGroupKeyFile
|
|
<&> show . pretty
|
|
|
|
pure $ mkStr s
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do
|
|
case syn of
|
|
[LitStrVal s] -> do
|
|
|
|
let lbs = LBS8.pack (Text.unpack s)
|
|
gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
|
|
`orDie` "invalid group key"
|
|
|
|
let rcpt = recipients gk & HM.keys & fmap (mkStr . show . pretty . AsBase58)
|
|
|
|
pure $ mkList @c rcpt
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
|
|
[BlobLike bs] -> flip runContT pure do
|
|
|
|
sto <- ContT withPeerStorage
|
|
|
|
let lbs = LBS.fromStrict bs
|
|
|
|
seb <- pure (deserialiseOrFail lbs)
|
|
`orDie` "invalid SmallEncryptedBlock"
|
|
|
|
decrypted <- lift $ G.decryptBlock sto seb
|
|
|
|
pure $ mkForm @c "blob" [mkStr (BS8.unpack decrypted)]
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
entry $ bindMatch "hbs2:groupkey:encrypt-block" $ \case
|
|
[StringLike gkh, BlobLike what] -> do
|
|
flip runContT pure do
|
|
sto <- ContT withPeerStorage
|
|
gk <- lift $ loadGroupKey (fromString gkh)
|
|
`orDie` "can't load group key"
|
|
seb <- lift $ G.encryptBlock sto gk what
|
|
pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))]
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|