hbs2/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs

module HBS2.CLI.Run.GroupKey
  ( module HBS2.CLI.Run.GroupKey
  , loadGroupKey
  ) where

import HBS2.CLI.Prelude hiding (mapMaybe)

import HBS2.Data.Types.Refs
import HBS2.Storage.Operations.Class
import HBS2.Storage.Operations.ByteString
import HBS2.Base58
import HBS2.CLI.Run.Internal
import HBS2.CLI.Run.Internal.GroupKey as G
import HBS2.Net.Auth.GroupKeySymm as Symm
import HBS2.Storage

import HBS2.KeyMan.Keys.Direct

import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.Client
import HBS2.Peer.RPC.Client.Unix

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 Control.Monad.Except
import Codec.Serialise

{- HLINT ignore "Functor law" -}


groupKeyEntries :: forall c m . ( MonadUnliftIO m
                                , IsContext c
                                , Exception (BadFormException c)
                                , HasClientAPI StorageAPI UNIX m
                                , HasStorage m
                                ) => MakeDictM c m ()
groupKeyEntries = do

  entry $ bindMatch "hbs2:groupkey:load" $ \case
      [HashLike h] -> do
        sto <- getStorage

        gk <- loadGroupKey h
                >>= orThrowUser "can not load groupkey"

        pure $ mkStr (show $ pretty $ AsGroupKeyFile gk)

      _ -> throwIO $ BadFormException @C nil


  brief "stores groupkey to the peer's storage" $
   args [arg "string" "groupkey"] $
   returns "string" "hash" $
    entry $ bindMatch "hbs2:groupkey:store" $ \case
        [LitStrVal s] -> do
          let lbs = LBS8.pack (Text.unpack s)
          gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
                  `orDie` "invalid group key"

          sto <- getStorage
          ha <- writeAsMerkle sto (serialise gk)
          pure $ mkStr (show $ pretty ha)

        _ -> throwIO $ BadFormException @c nil


  brief "publish groupkey to the given refchan" $
    args [arg "string" "refchan", arg "string" "groupkey-blob|groupkey-hash"] $
    desc "groupkey may be also hash of te stored groupkey" $
      entry $ bindMatch "hbs2:groupkey:publish" $ nil_ $ \case

      [SignPubKeyLike rchan, LitStrVal gk] -> do
        -- get
        -- check
        -- store
        -- find refchan
        -- post tx as metadata
        notice $ red "not implemented yet"

      [SignPubKeyLike rchan, HashLike gkh] -> do
        notice $ red "not implemented yet"

      _ -> 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

      sto <- getStorage

      let lbs = LBS8.pack (Text.unpack s)
      gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
              `orDie` "invalid group key"

      gk1 <- modifyGroupKey gk ins

      pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1)

    _ -> throwIO $ BadFormException @C nil

  brief "create group key" $
    args [ arg "keys" "list" ] $
    desc "list of encryption public keys of members" $
    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:dump" $ nil_ $ \syn -> do
    case syn of
      -- TODO: from-file
      -- TODO: from-stdin
      -- TODO: base58 file
      [HashLike gkh] -> do
        gk <- loadGroupKey gkh
        liftIO $ print $ pretty gk

      _ -> 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

  brief "find groupkey secret in hbs2-keyman" $
    args [arg "string" "group-key-hash"] $
    returns "secret-key-id" "string" $
    entry $ bindMatch "hbs2:groupkey:find-secret" $ \case
      [HashLike gkh] -> do

        sto <- getStorage

        gk <- loadGroupKey gkh >>= orThrowUser "can't load groupkey"

        what <- runKeymanClient $ findMatchedGroupKeySecret sto gk
                   >>= orThrowUser "groupkey secret not found"

        let gid = generateGroupKeyId GroupKeyIdBasic1 what

        pure $ mkStr (show $ pretty gid)

      _ -> throwIO $ BadFormException @c nil


  entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
    [BlobLike bs] -> do

      sto <- getStorage

      let lbs = LBS.fromStrict bs

      seb <- pure (deserialiseOrFail lbs)
               `orDie` "invalid SmallEncryptedBlock"

      decrypted <- 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
        sto <- getStorage
        gk <- loadGroupKey (fromString gkh)
                `orDie` "can't load group key"
        seb <- G.encryptBlock sto gk what
        pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))]

    _ -> throwIO $ BadFormException @C nil