symmetric, deterministic merkle-tree encryption

suckless-conf bumped

docs/devlog.md

@@ -1,3 +1,5 @@
+## 2023-09-25
+
 ## 2023-14-08
 
 PR: hbs2-git-config-location

flake.lock

@@ -295,15 +295,16 @@
         ]
       },
       "locked": {
-        "lastModified": 1689215736,
+        "lastModified": 1695116151,
-        "narHash": "sha256-cd/iK5ttyls62RI5JYYANf2O8rV6Ubu1a/4VXDrQCBc=",
+        "narHash": "sha256-AjjfTL41SRZFy9HjQ6XKvS9kjfplkJKBIkcBvi1mKkc=",
         "owner": "voidlizard",
         "repo": "suckless-conf",
-        "rev": "0ee3ef62e833df65da99af3feba9feaa7ef4d12b",
+        "rev": "eef15613402380b9b67c68a0e8a22a71250daa98",
         "type": "github"
       },
       "original": {
         "owner": "voidlizard",
+        "ref": "master",
         "repo": "suckless-conf",
         "type": "github"
       }

flake.nix

@@ -12,7 +12,7 @@ inputs = {
     fixme.url = "github:voidlizard/fixme";
     fixme.inputs.nixpkgs.follows = "nixpkgs";
 
-    suckless-conf.url = "github:voidlizard/suckless-conf";
+    suckless-conf.url = "github:voidlizard/suckless-conf/master";
     suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
 
     saltine = {

hbs2-core/hbs2-core.cabal

@@ -84,12 +84,14 @@ library
                     , HBS2.Data.Types.Peer
                     , HBS2.Data.Types.Refs
                     , HBS2.Data.Types.SignedBox
+                    , HBS2.Data.Types.EncryptedBox
                     , HBS2.Data.Bundle
                     , HBS2.Defaults
                     , HBS2.Events
                     , HBS2.Hash
                     , HBS2.Merkle
-                    , HBS2.Net.Auth.AccessKey
+                    , HBS2.Net.Auth.GroupKeyAsymm
+                    , HBS2.Net.Auth.GroupKeySymm
                     , HBS2.Net.Auth.Credentials
                     , HBS2.Net.IP.Addr
                     , HBS2.Net.Messaging
@@ -120,7 +122,8 @@ library
                     , HBS2.Prelude
                     , HBS2.Prelude.Plated
                     , HBS2.Storage
-                    , HBS2.Storage.Operations
+                    , HBS2.Storage.Operations.Class
+                    , HBS2.Storage.Operations.ByteString
                     , HBS2.System.Logger.Simple
                     , HBS2.System.Logger.Simple.Class
                     , HBS2.Net.Dialog.Core

hbs2-core/lib/HBS2/Data/Bundle.hs

@@ -4,7 +4,7 @@ module HBS2.Data.Bundle where
 
 import HBS2.Prelude
 import HBS2.Storage
-import HBS2.Storage.Operations
+import HBS2.Storage.Operations.ByteString
 import HBS2.Hash
 import HBS2.Data.Types.Refs
 import HBS2.Data.Types.SignedBox
@@ -14,17 +14,12 @@ import HBS2.Data.Detect
 
 import Data.Word
 
-import Data.Function
 import Codec.Compression.GZip as GZip
 import Codec.Serialise
 import Control.Monad
-import Control.Monad.Trans.Maybe
 import Data.ByteString.Lazy.Char8 (ByteString)
 import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Functor
-import Data.List qualified as List
 import Data.Either
-import Data.Maybe
 
 import Streaming.Prelude qualified as S
 import Streaming()

hbs2-core/lib/HBS2/Data/Detect.hs

@@ -95,8 +95,10 @@ deepScan l miss from reader sink = do
 
           -- FIXME: ASAP-support-encryption
           CryptAccessKeyNaClAsymm{} -> do
-            err "deepScan does not support encryption yet"
+            lift $ walkTree (_mtaTree ann)
-            pure ()
+
+          EncryptGroupNaClSymm{} -> do
+            lift $ walkTree (_mtaTree ann)
 
          SeqRef (SequentialRef _ (AnnotatedHashRef ann hx)) -> do
            lift $ maybe1 ann (pure ()) sinkDeep

hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs

@@ -0,0 +1,14 @@
+module HBS2.Data.Types.EncryptedBox where
+
+import HBS2.Prelude.Plated
+
+import Codec.Serialise
+import Data.ByteString (ByteString)
+
+-- TODO: encryption-type-into-tags
+-- FIXME: show-scrambled?
+newtype EncryptedBox t = EncryptedBox { unEncryptedBox :: ByteString }
+  deriving stock (Generic,Show,Data)
+
+instance Serialise (EncryptedBox t)
+

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -23,6 +23,7 @@ newtype HashRef = HashRef { fromHashRef :: Hash HbSync }
                   deriving stock (Data,Generic,Show)
 
 
+
 instance Pretty (AsBase58 HashRef) where
   pretty (AsBase58 x) = pretty x
   -- TODO: should be instance Pretty (AsBase58 (Hash HbSync))
@@ -30,6 +31,16 @@ instance Pretty (AsBase58 HashRef) where
 instance FromStringMaybe HashRef where
   fromStringMay = fmap HashRef . fromStringMay
 
+newtype TheHashRef t = TheHashRef { fromTheHashRef :: Hash HbSync }
+                      deriving newtype (Eq,Ord,IsString,Pretty,Hashable)
+                      deriving stock (Data,Generic,Show)
+
+instance Pretty (AsBase58 (TheHashRef t)) where
+  pretty (AsBase58 x) = pretty x
+
+instance FromStringMaybe (TheHashRef t) where
+  fromStringMay = fmap TheHashRef . fromStringMay
+
 data HashRefObject = HashRefObject HashRef (Maybe HashRefMetadata)
   deriving stock (Data,Show,Generic)
 

hbs2-core/lib/HBS2/Hash.hs

@@ -39,6 +39,8 @@ data HsHash
 type family HashType ( a :: Type) where
   HashType HbSync = Blake2b_256
 
+type HbSyncHash = HashType HbSync
+
 newtype instance Hash HbSync =
   HbSyncHash ByteString
   deriving stock (Eq,Ord,Data,Generic)
@@ -54,7 +56,6 @@ class Hashed t a where
   hashObject :: a -> Hash t
 
 
-
 instance Hashed HbSync ByteString where
   hashObject s = HbSyncHash $! BA.convert digest
     where

hbs2-core/lib/HBS2/Merkle.hs

@@ -87,7 +87,7 @@ data MTreeAnn a = MTreeAnn
  , _mtaCrypt :: !MTreeEncryption
  , _mtaTree :: !(MTree a)
  }
-  deriving stock (Generic,Data,Show)
+ deriving stock (Generic,Data,Show)
 
 instance Serialise a => Serialise (MTreeAnn a)
 
@@ -97,7 +97,8 @@ data MerkleEncryptionType
 data MTreeEncryption
   = NullEncryption
   | CryptAccessKeyNaClAsymm (Hash HbSync)
-  deriving stock (Generic,Data,Show)
+  | EncryptGroupNaClSymm (Hash HbSync)
+  deriving stock (Eq,Generic,Data,Show)
 
 instance Serialise MTreeEncryption
 

hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs

@@ -1,12 +1,12 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# Language TemplateHaskell #-}
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language ConstraintKinds #-}
-module HBS2.Net.Auth.AccessKey where
+module HBS2.Net.Auth.GroupKeyAsymm where
 
 import HBS2.Base58
 import HBS2.Data.Types
+import HBS2.Data.Types.EncryptedBox
 import HBS2.Merkle
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition
@@ -31,10 +31,6 @@ type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s)
                       )
 
 
-newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString }
-  deriving stock (Generic)
-
-instance Serialise EncryptedBox
 
 ---
 
@@ -42,7 +38,7 @@ data family AccessKey s
 
 newtype instance AccessKey s =
   AccessKeyNaClAsymm
-  { permitted :: [(PubKey 'Encrypt s, EncryptedBox)]
+  { permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))]
   }
   deriving stock (Generic)
 
@@ -50,37 +46,35 @@ instance ForAccessKey s => Serialise (AccessKey s)
 
 ---
 
-data family GroupKey s
 
-data instance GroupKey s =
+data instance GroupKey 'Asymm s =
   GroupKeyNaClAsymm
   { recipientPk :: PubKey 'Encrypt s
   , accessKey :: AccessKey s
   }
   deriving stock (Generic)
 
-instance ForAccessKey s => Serialise (GroupKey s)
+instance ForAccessKey s => Serialise (GroupKey 'Asymm s)
 
 ---
 
-newtype AsGroupKeyFile a = AsGroupKeyFile a
 
 -- FIXME: integration-regression-test-for-groupkey
 --   Добавить тест: сгенерировали groupkey/распарсили groupkey
 
 parseGroupKey :: forall s . ForAccessKey s
-                 =>  AsGroupKeyFile ByteString -> Maybe (GroupKey s)
+                 =>  AsGroupKeyFile ByteString -> Maybe (GroupKey 'Asymm s)
 parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 bs
 
-instance ( Serialise  (GroupKey s)
+instance ( Serialise  (GroupKey 'Asymm s)
          )
 
-  =>  Pretty (AsBase58 (GroupKey s)) where
+  =>  Pretty (AsBase58 (GroupKey 'Asymm s)) where
   pretty (AsBase58 c) =
     pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
 
 
-instance Pretty (AsBase58 a) => Pretty (AsGroupKeyFile (AsBase58 a)) where
+instance ForAccessKey s => Pretty (AsGroupKeyFile (AsBase58 (GroupKey 'Asymm s))) where
   pretty (AsGroupKeyFile pc) =  "# hbs2 groupkey file" <> line <> co
     where
       co = vcat $ fmap pretty
@@ -101,7 +95,7 @@ parsePubKeys = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines
 mkEncryptedKey :: forall s . (ForAccessKey s, PubKey 'Encrypt s ~ Encrypt.PublicKey)
                => KeyringEntry s
                -> PubKey 'Encrypt s
-               -> IO EncryptedBox
+               -> IO (EncryptedBox (KeyringEntry s))
 
 mkEncryptedKey kr pk = EncryptedBox <$> Encrypt.boxSeal pk ((LBS.toStrict . serialise) kr)
 
@@ -109,7 +103,7 @@ openEncryptedKey :: forall s . ( ForAccessKey s
                                , PrivKey 'Encrypt s ~ Encrypt.SecretKey
                                , PubKey 'Encrypt s ~ Encrypt.PublicKey
                                )
-                 => EncryptedBox
+                 => EncryptedBox (KeyringEntry s)
                  -> KeyringEntry s
                  -> Maybe (KeyringEntry s)
 

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -0,0 +1,292 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language ConstraintKinds #-}
+module HBS2.Net.Auth.GroupKeySymm where
+
+import HBS2.Prelude.Plated
+import HBS2.Base58
+import HBS2.Data.Types.EncryptedBox
+import HBS2.Data.Types.Refs
+import HBS2.Hash
+import HBS2.Merkle
+import HBS2.Data.Detect
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
+import HBS2.Storage(Storage(..))
+
+import HBS2.System.Logger.Simple
+
+import Data.ByteArray.Hash qualified as BA
+
+import Codec.Serialise
+import Crypto.KDF.HKDF qualified as HKDF
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Identity
+import Control.Monad.Trans.Maybe
+import Control.Monad.Writer
+import Crypto.Saltine.Class qualified as Saltine
+import Crypto.Saltine.Core.Box qualified as AK
+import Crypto.Saltine.Core.SecretBox (Key)
+import Crypto.Saltine.Core.SecretBox qualified as SK
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Char8 qualified as B8
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Function
+import Data.Functor
+import Data.List qualified as List
+import Data.List.Split (chunksOf)
+import Data.Maybe
+import Data.Word (Word64)
+import Data.ByteArray()
+import Network.ByteOrder qualified as N
+import Streaming.Prelude qualified as S
+import Lens.Micro.Platform
+
+import Streaming qualified as S
+import Streaming (Stream(..), Of(..))
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Data.Bits (xor)
+
+type GroupSecretAsymm = Key
+
+data instance GroupKey 'Symm s =
+  GroupKeySymm
+  { recipients :: [(PubKey 'Encrypt s, EncryptedBox GroupSecretAsymm)]
+  }
+  deriving stock (Generic)
+
+instance Serialise Key
+instance Serialise SK.Nonce
+
+-- NOTE: hardcoded-hbs2-basic-auth-type
+data instance ToEncrypt 'Symm s LBS.ByteString =
+  ToEncryptSymmBS
+  { toEncryptSecret      :: GroupSecretAsymm
+  , toEncryptData        :: Stream (Of LBS.ByteString) IO ()
+  , toEncryptGroupKey    :: GroupKey 'Symm s
+  }
+
+
+type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
+                         , PubKey 'Encrypt s ~ AK.PublicKey
+                         , PrivKey 'Encrypt s ~ AK.SecretKey
+                         , Serialise (PubKey 'Encrypt s)
+                         , Serialise GroupSecretAsymm
+                         , Serialise SK.Nonce
+                         , FromStringMaybe (PubKey 'Encrypt s)
+                         )
+
+instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s)
+
+instance Pretty (AsBase58 (PubKey 'Encrypt s)) => Pretty (GroupKey 'Symm s) where
+  pretty g = vcat (fmap prettyEntry (recipients g))
+    where
+      prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk))
+
+
+instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where
+  pretty (AsGroupKeyFile pc) =  "# hbs2 symmetric group key file"
+                                <> line <> co
+    where
+      co = vcat $ fmap pretty
+                $ chunksOf 60
+                $ show
+                $ pretty (AsBase58 (serialise pc))
+
+
+parseGroupKey :: forall s . (ForGroupKeySymm s, Serialise (GroupKey 'Symm s))
+                 =>  AsGroupKeyFile ByteString
+                 ->  Maybe (GroupKey 'Symm s)
+
+parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 (LBS8.toStrict bs)
+
+instance ( Serialise  (GroupKey 'Asymm s)
+         )
+
+  =>  Pretty (AsBase58 (GroupKey 'Asymm s)) where
+  pretty (AsBase58 c) =
+    pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
+
+generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m)
+                 => [PubKey 'Encrypt s]
+                 -> m (GroupKey 'Symm s)
+
+generateGroupKey pks' = GroupKeySymm <$> create
+  where
+    pks = List.sort (List.nub pks')
+
+    create = do
+      sk <- liftIO SK.newKey
+      forM pks $ \pk -> do
+        box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
+        pure (pk, box)
+
+lookupGroupKey :: ForGroupKeySymm s
+               => PrivKey 'Encrypt s
+               -> PubKey 'Encrypt s
+               -> GroupKey 'Symm s
+               -> Maybe GroupSecretAsymm
+
+lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
+  (EncryptedBox bs) <- MaybeT $ pure $ List.lookup pk (recipients gk)
+  -- error  "FOUND SHIT!"
+  gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs
+  -- error $ "DECRYPTED SHIT!"
+  MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
+
+-- FIXME: move-to-appropriate-place
+class NonceFrom a nonce where
+  nonceFrom :: nonce -> a -> nonce
+
+typicalNonceLength :: Integral a => a
+typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length & fromIntegral
+
+typicalKeyLength :: Integral a => a
+typicalKeyLength = unsafePerformIO SK.newKey & Saltine.encode & B8.length & fromIntegral
+
+instance NonceFrom Word64 SK.Nonce where
+  -- FIXME: maybe-slow-nonceFrom
+  nonceFrom n0 w = fromJust $ Saltine.decode nss
+    where
+      ws = noncePrefix <> N.bytestring64 w
+      ns = Saltine.encode n0
+      nss = BS.packZipWith xor ns ws
+
+      noncePrefix = BS.replicate (typicalNonceLength - 8) 0
+
+-- Раз уж такое, то будем писать метаинформацию
+-- В блок #0,
+-- А HashRef#1 - будет ссылка на групповой ключ
+-- Таким образом, мы обеспечим прозрачное скачивание
+-- блоков, не будем экспонировать лишнюю метаинформацию,
+-- но вместе с тем раздуваем количество раундтрипов,
+-- это вообще касается такого способа сохранения
+-- Merkle Tree.
+-- Но накладные расходны не так велики, упрощается
+-- сборка мусора, упрощается код. Нам не надо делать
+-- специальную обработку на каждый тип данных,
+-- достаточно иметь [HashRef].
+
+instance ( MonadIO m
+         , MonadError OperationError m
+         , Storage sto h ByteString m
+         , Storage sto h ByteString IO
+         , h ~ HbSync
+         , ForGroupKeySymm s
+         ) => MerkleWriter (ToEncrypt 'Symm s ByteString) h sto m where
+
+  type instance ToBlockW (ToEncrypt 'Symm s ByteString) = ByteString
+
+  writeAsMerkle sto source = do
+
+    let gk = toEncryptGroupKey source
+
+    let key = toEncryptSecret source
+
+    gkh <- writeAsMerkle sto (serialise gk) <&> HashRef
+
+    let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode key)
+
+    hashes' <- liftIO $ toEncryptData source
+
+                & S.mapM ( \bs -> do
+                             let (BA.SipHash w64) = BA.sipHash (BA.SipKey 11940070621075034887 442907749530188102) (LBS.toStrict bs)
+                             let hbs = N.bytestring64 w64
+                             let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust
+                             let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0)
+                             let nonce = Saltine.decode nonceS & fromJust
+                             let encrypted = SK.secretbox key0 nonce (LBS.toStrict bs)
+                             pure $ serialise (hbs, encrypted)
+                         )
+
+                & S.mapM (enqueueBlock sto)
+                & S.map (fmap HashRef)
+                & S.toList_
+
+    let hashes = catMaybes hashes'
+
+--     -- FIXME: handle-hardcode
+    let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings
+
+    -- FIXME: this-might-not-be-true
+    result <- runWriterT $ makeMerkle 0 pt $ \(_,mt,bss) -> do
+      void $ lift $ putBlock sto bss
+      tell [mt]
+
+    let root = headMay (snd result)
+
+    tree <- maybe (throwError StorageError) pure root
+
+    let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh)) tree
+
+    putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure
+
+
+instance ( MonadIO m
+         , MonadError OperationError m
+         , h ~ HbSync
+         , Storage s h ByteString m
+         -- TODO: why?
+         , sch ~ HBS2Basic
+         ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
+
+  data instance TreeKey (ToDecrypt 'Symm sch ByteString) = ToDecryptBS [KeyringEntry sch] (Hash HbSync)
+
+  type instance ToBlockR  (ToDecrypt 'Symm sch ByteString) = ByteString
+  type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString
+
+  readFromMerkle sto (ToDecryptBS ke h) = do
+
+    let keys = [ (view krPk x, view krSk x) | x <- ke ]
+
+    bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure
+    let what = tryDetect h bs
+
+    let tree' = case what of
+          MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g}) -> Just (_mtaTree ann, g)
+          _ -> Nothing
+
+    (tree, gkh) <- maybe1 tree' (throwError UnsupportedFormat) pure
+
+    gkbs <- readFromMerkle sto (SimpleKey gkh)
+
+    gk <- either (const $ throwError GroupKeyNotFound) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs)
+
+    let gksec' = [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay
+
+    gksec <- maybe1 gksec' (throwError GroupKeyNotFound) pure
+
+    let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec)
+
+    hashes <- S.toList_ $
+      walkMerkleTree tree (lift . getBlock sto) $ \case
+        Left{} -> throwError MissedBlockError
+        Right hrr -> S.each hrr
+
+    ss <- forM hashes $ \h -> do
+      blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure
+
+      (hbs, bss) <- either (const $ throwError UnsupportedFormat)
+                          pure
+                          (deserialiseOrFail @(BS.ByteString, BS.ByteString) blk)
+
+
+      let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0)
+      let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust
+      let nonce = Saltine.decode nonceS & fromJust
+      let unboxed = SK.secretboxOpen key0 nonce bss
+
+      maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
+
+    pure $ mconcat ss
+
+
+

hbs2-core/lib/HBS2/Net/Proto/Definition.hs

@@ -24,7 +24,7 @@ import HBS2.Net.Proto.PeerMeta
 import HBS2.Net.Proto.RefLog
 import HBS2.Net.Proto.RefChan
 import HBS2.Net.Messaging.Unix (UNIX)
-import HBS2.Prelude
+import HBS2.Prelude.Plated
 
 import Control.Monad
 import Data.Functor
@@ -48,6 +48,7 @@ type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
 type instance PubKey  'Encrypt HBS2Basic = Encrypt.PublicKey
 type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
 
+
 -- FIXME: proper-serialise-for-keys
 --   Возможно, нужно написать ручные инстансы Serialise
 --   использовать encode/decode для каждого инстанса ниже $(c:end + 4)

hbs2-core/lib/HBS2/Net/Proto/Types.hs

@@ -24,17 +24,30 @@ import System.Random qualified as Random
 import Codec.Serialise
 import Data.Maybe
 import Control.Monad.Trans.Maybe
+import Data.ByteString (ByteString)
 
 -- e -> Transport (like, UDP or TChan)
 -- p -> L4 Protocol (like Ping/Pong)
 
 data CryptoAction = Sign | Encrypt
 
-type family PubKey  ( a :: CryptoAction) e  :: Type
+data GroupKeyScheme = Symm | Asymm
-type family PrivKey ( a :: CryptoAction) e  :: Type
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+type family PubKey  (a :: CryptoAction) e  :: Type
+type family PrivKey (a :: CryptoAction) e  :: Type
 
 type family Encryption e :: Type
 
+data family GroupKey (scheme :: GroupKeyScheme) s
+
+-- TODO: move-to-an-appropriate-place
+newtype AsGroupKeyFile a = AsGroupKeyFile a
+
+data family ToEncrypt (scheme :: GroupKeyScheme) s a -- = ToEncrypt a
+
+data family ToDecrypt (scheme :: GroupKeyScheme) s a
+
 -- FIXME: move-to-a-crypto-definition-modules
 data HBS2Basic
 

hbs2-core/lib/HBS2/Storage/Operations.hs

@@ -1,38 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-{-# Language UndecidableInstances #-}
-module HBS2.Storage.Operations where
-
-import HBS2.Prelude.Plated
-import HBS2.Hash
-import HBS2.Storage
-import HBS2.Merkle
-import HBS2.Data.Types.Refs
-import HBS2.Defaults
-
-import Streaming.Prelude qualified as S
-import Streaming qualified as S
-import Data.Functor
-import Data.Function
-
-import Data.Bifunctor
-import Data.ByteString.Lazy (ByteString)
-import Data.ByteString.Lazy qualified as B
-
-
-class (MonadIO m, Storage storage hash block m) => MerkleWriter block hash storage m where
-  writeAsMerkle :: storage -> block -> m (Hash hash)
-
-instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where
-  writeAsMerkle sto bs = do
-
-    hashes <- S.each (B.unpack bs)
-                & S.chunksOf (fromIntegral defBlockSize)
-                & S.mapped (fmap (first B.pack) . S.toList)
-                & S.mapM (\blk -> enqueueBlock sto blk >> pure blk)
-                & S.map (HashRef . hashObject)
-                & S.toList_
-
-    -- FIXME: handle-hardcode
-    let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings
-    makeMerkle 0 pt $ \(_,_,bss) -> void $ putBlock sto bss
-

hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs

@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Storage.Operations.ByteString
+  ( module HBS2.Storage.Operations.Class
+  , module HBS2.Storage.Operations.ByteString
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Storage
+import HBS2.Merkle
+import HBS2.Data.Types.Refs
+import HBS2.Defaults
+
+import HBS2.Storage.Operations.Class
+
+import Streaming.Prelude qualified as S
+import Streaming qualified as S
+import Data.Function
+
+import Control.Monad.Except
+import Data.Bifunctor
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+
+
+instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where
+  type instance ToBlockW ByteString = ByteString
+  writeAsMerkle sto bs = do
+
+    hashes <- S.each (LBS.unpack bs)
+                & S.chunksOf (fromIntegral defBlockSize)
+                & S.mapped (fmap (first LBS.pack) . S.toList)
+                & S.mapM (\blk -> enqueueBlock sto blk >> pure blk)
+                & S.map (HashRef . hashObject)
+                & S.toList_
+
+    -- FIXME: handle-hardcode
+    let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings
+    makeMerkle 0 pt $ \(_,_,bss) -> void $ putBlock sto bss
+
+
+instance ( MonadIO m
+         , MonadError OperationError m
+         , Storage s HbSync ByteString m
+         ) => MerkleReader ByteString s HbSync m where
+
+  newtype instance TreeKey ByteString = SimpleKey (Hash HbSync)
+  type instance ToBlockR ByteString = ByteString
+  type instance ReadResult ByteString = ByteString
+
+  readFromMerkle sto (SimpleKey h) = do
+
+    pieces <- S.toList_ $ do
+      walkMerkle h (lift . getBlock sto) $ \case
+        Left{} -> throwError MissedBlockError
+
+        Right (hrr :: [HashRef]) -> do
+
+            forM_ hrr $ \hx -> do
+              blk <- lift (getBlock sto (fromHashRef hx))
+                        >>= maybe (throwError MissedBlockError) pure
+              S.yield blk
+
+    pure $ mconcat pieces
+
+

hbs2-core/lib/HBS2/Storage/Operations/Class.hs

@@ -0,0 +1,31 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Storage.Operations.Class where
+
+import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Storage
+
+import Data.Kind
+
+data OperationError =
+    StorageError
+  | CryptoError
+  | DecryptionError
+  | MissedBlockError
+  | UnsupportedFormat
+  | GroupKeyNotFound
+  deriving (Generic,Show,Data,Typeable)
+
+-- instance Exception OperationError
+
+class (MonadIO m, Storage storage hash (ToBlockW s) m) => MerkleWriter s hash storage m where
+  type family ToBlockW s :: Type
+  writeAsMerkle :: storage -> s -> m (Hash hash)
+
+
+class (MonadIO m, Storage storage h (ToBlockR s) m) => MerkleReader s storage h m where
+  data family TreeKey s :: Type
+  type family ToBlockR s :: Type
+  type family ReadResult s :: Type
+  readFromMerkle :: storage -> TreeKey s -> m (ReadResult s)
+

hbs2-peer/app/BlockDownload.hs

@@ -156,9 +156,10 @@ processBlock h = do
           ShortMetadata {} -> pure ()
           AnnHashRef hx -> addDownload parent hx
 
-       case (_mtaCrypt ann) of
+       case _mtaCrypt ann of
           NullEncryption -> pure ()
           CryptAccessKeyNaClAsymm h -> addDownload parent h
+          EncryptGroupNaClSymm h    -> addDownload parent h
 
        debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h
        walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr

hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs

@@ -32,9 +32,11 @@ import System.IO
 pieces :: Integral a => a
 pieces = 1024
 
+-- FIXME: to-remove-in-a-sake-of-operations-class
 class SimpleStorageExtra a  where
   putAsMerkle :: forall h . (IsSimpleStorageKey h, Hashed h ByteString) => SimpleStorage h -> a -> IO MerkleHash
 
+-- TODO: move-to-hbs2-storage-operations
 readChunked :: MonadIO m => Handle -> Int -> S.Stream (S.Of ByteString) m ()
 readChunked handle size = fuu
   where
@@ -45,6 +47,24 @@ readChunked handle size = fuu
       S.yield chunk
       next
 
+-- TODO: sparse-merkle-tree-representation
+--  Блоки пишутся таким образом потому,
+--  что хотелось, что бы листы являлись частями
+--  исходной информации без всяких метаданных,
+--  то есть каждый блок в отдельности является
+--  только частью исходных данных, а их конкатенация
+--  является этими самыми данными. Это менее оптимальное
+--  представление для передачи, но в этом есть смысл.
+--
+--  то есть у нас есть Merkle Tree которое как бы
+--  является торрентом неограниченного размера,
+--  скачиваемого по частям, в котором множество
+--  указателей на реальные файлы. Имеет смысл.
+--
+--  Мы в принципе можем измененить способ записи,
+--  интересно, что при этом особо ничего не поменяется ---
+--  то есть система будет продолжать работать.
+
 instance SimpleStorageExtra Handle where
   putAsMerkle ss handle = do
 

hbs2-storage-simple/test/Main.hs

@@ -5,8 +5,6 @@ import Test.Tasty.HUnit
 
 import TestSimpleStorage
 
-import HBS2.Storage
-
 main :: IO ()
 main =
   defaultMain $
@@ -16,6 +14,7 @@ main =
       , testCase "testSimpleStorageNoKeys" testSimpleStorageNoKeys
       , testCase "testSimpleStorageRefs" testSimpleStorageRefs
       , testCase "testSimpleStorageBundles" testSimpleStorageBundles
+      , testCase  "testSimpleStorageSymmEncryption" testSimpleStorageSymmEncryption
       ]
 
 

hbs2-storage-simple/test/TestSimpleStorage.hs

@@ -255,3 +255,18 @@ testSimpleStorageBundles  = do
     assertBool "all-blocks-here-again" (not (null (catMaybes hereWeGoAgain)))
 
 
+testSimpleStorageSymmEncryption :: IO ()
+testSimpleStorageSymmEncryption  = do
+  withSystemTempDirectory "simpleStorageTest" $ \dir -> do
+
+    let opts = [ StoragePrefix (dir </> ".storage")
+               ]
+
+    storage <- simpleStorageInit opts :: IO (SimpleStorage HbSync)
+
+    worker <- async  (simpleStorageWorker storage)
+
+    link worker
+
+    assertBool "nothing" True
+

hbs2/Main.hs

@@ -3,15 +3,20 @@ module Main where
 import HBS2.Base58
 import HBS2.Data.Detect
 import HBS2.Data.Types
+import HBS2.Data.Types.EncryptedBox
 import HBS2.Defaults
 import HBS2.Merkle
 import HBS2.Net.Proto.Types
-import HBS2.Net.Auth.AccessKey
+import HBS2.Net.Auth.GroupKeyAsymm as Asymm
+import HBS2.Net.Auth.GroupKeySymm qualified as Symm
+import HBS2.Net.Auth.GroupKeySymm
+-- (ToEncrypt(..))
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition()
 import HBS2.Net.Proto.RefLog(RefLogKey(..))
 import HBS2.Net.Proto.AnyRef(AnyRefKey(..))
 import HBS2.Prelude.Plated
+import HBS2.Storage.Operations.Class
 import HBS2.Storage.Simple
 import HBS2.Storage.Simple.Extra
 import HBS2.Data.Bundle
@@ -20,9 +25,13 @@ import HBS2.OrDie
 
 import HBS2.System.Logger.Simple hiding (info)
 
+import Data.Config.Suckless
+import Data.Config.Suckless.KeyValue
+
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
+import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.ByteString.Lazy qualified as LBS
@@ -36,7 +45,9 @@ import Data.Map.Strict qualified as Map
 import Data.Monoid qualified as Monoid
 import Options.Applicative
 import System.Directory
+import Data.Either
 import Data.Maybe
+import Data.Text qualified as Text
 import Lens.Micro.Platform
 -- import System.FilePath.Posix
 import System.IO
@@ -49,19 +60,19 @@ import Streaming.Prelude qualified as S
 
 
 tracePrefix :: SetLoggerEntry
-tracePrefix  = logPrefix "[trace] "
+tracePrefix  = logPrefix "[trace] " . toStderr
 
 debugPrefix :: SetLoggerEntry
-debugPrefix  = logPrefix "[debug] "
+debugPrefix  = logPrefix "[debug] " . toStderr
 
 errorPrefix :: SetLoggerEntry
-errorPrefix  = logPrefix "[error] "
+errorPrefix  = logPrefix "[error] " . toStderr
 
 warnPrefix :: SetLoggerEntry
-warnPrefix   = logPrefix "[warn] "
+warnPrefix   = logPrefix "[warn] " . toStderr
 
 noticePrefix :: SetLoggerEntry
-noticePrefix = logPrefix "[notice] "
+noticePrefix = logPrefix "[notice] " . toStderr
 
 
 newtype CommonOpts =
@@ -87,16 +98,22 @@ newtype OptGroupkeyFile = OptGroupkeyFile { unOptGroupkeyFile :: FilePath }
                        deriving newtype (Eq,Ord,IsString)
                        deriving stock (Data)
 
+newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt HBS2Basic  }
+                       deriving newtype (Eq,Ord)
+                       deriving stock (Data)
+
 newtype OptInit = OptInit { fromOptInit :: Bool }
                   deriving newtype (Eq,Ord,Pretty)
                   deriving stock (Data,Generic)
 
 data StoreOpts =
   StoreOpts
-  {  storeInit      :: Maybe OptInit
+  {  storeInit         :: Maybe OptInit
-  ,  storeInputFile :: Maybe OptInputFile
+  ,  storeInputFile    :: Maybe OptInputFile
   ,  storeGroupkeyFile :: Maybe OptGroupkeyFile
-  ,  storeBase58Meta :: Maybe String
+  ,  storeBase58Meta   :: Maybe String
+  ,  storeEncPubKey    :: Maybe OptEncPubKey
+  ,  storeKeyringFile  :: Maybe OptKeyringFile
   }
   deriving stock (Data)
 
@@ -122,6 +139,9 @@ newtype NewRefOpts =
   deriving stock (Data)
 
 
+data EncSchema  = EncSymm   (GroupKey 'Symm HBS2Basic)
+                | EncAsymm  (GroupKey 'Asymm HBS2Basic)
+
 runHash :: HashOpts -> SimpleStorage HbSync -> IO ()
 runHash opts _ = do
   withBinaryFile (hashFp opts) ReadMode $ \h -> do
@@ -173,6 +193,10 @@ runCat opts ss = do
           walkAnn ann = do
             bprocess :: Hash HbSync -> ByteString -> IO ByteString <- case (_mtaCrypt ann) of
               NullEncryption -> pure (const pure)
+
+              EncryptGroupNaClSymm{} -> do
+                die "EncryptGroupNaClSymm is not supported yet"
+
               CryptAccessKeyNaClAsymm crypth -> do
 
                   keyringFile <- pure (uniLastMay @OptKeyringFile opts <&> unOptKeyringFile)
@@ -183,7 +207,7 @@ runCat opts ss = do
                       `orDie` "bad keyring file"
 
                   blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth)
-                  recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox)]
+                  recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))]
                     <- pure (deserialiseMay blkc)
                       `orDie` "can not deserialise access key"
 
@@ -215,8 +239,26 @@ runCat opts ss = do
 
       case q of
         Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr
+
         Merkle t -> walkMerkleTree t (getBlock ss) stepInside
 
+        MerkleAnn ann | honly -> do
+          walkMerkleTree (_mtaTree ann) (getBlock ss) $ \case
+            Left hx  -> err $ "missed block" <+> pretty hx
+            Right hr -> print $ vcat (fmap pretty hr)
+
+        MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm{}}) -> do
+
+          krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set"
+          s <- BS.readFile (unOptKeyringFile krf)
+          cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
+          let keyring = view peerKeyring cred
+
+          elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS keyring mhash)
+          case elbs of
+            Right lbs -> LBS.putStr lbs
+            Left e    -> die (show e)
+
         MerkleAnn ann -> walkAnn ann
 
         -- FIXME: what-if-multiple-seq-ref-?
@@ -265,32 +307,64 @@ runStore opts ss = do
         print $ "merkle-root: " <+> pretty root
 
     Just gkfile -> do
-        gk :: GroupKey HBS2Basic
-            <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile))
-            `orDie` "bad groupkey file"
 
-        accKeyh <- (putBlock ss . serialise . permitted . accessKey) gk
+      gkSymm  <- Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile)
-            `orDie` "can not store access key"
+      gkAsymm <- Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)
 
-        let rawChunks :: S.Stream (S.Of ByteString) IO ()
+      let mbGk = EncSymm <$> gkSymm <|> EncAsymm <$> gkAsymm
-            rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
 
-            encryptedChunks :: S.Stream (S.Of ByteString) IO ()
+      case mbGk of
-            encryptedChunks = rawChunks
+        Nothing -> die "unknown or invalid group key"
-                & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict)
 
-        mhash <- putAsMerkle ss encryptedChunks
+        Just (EncSymm gk) -> do
-        mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash))
+          pk  <- unOptEncPk <$> pure (uniLastMay @OptEncPubKey opts) `orDie` "public key not specified"
-            `orDie` "merkle tree was not stored properly with `putAsMerkle`"
+          krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set"
 
-        mannh <- maybe (die "can not store MerkleAnn") pure
+          s <- BS.readFile (unOptKeyringFile krf)
-              =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do
+          cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
-            MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree
 
-        print $ "merkle-ann-root: " <+> pretty mannh
+          sk <- pure (headMay [ (view krPk k, view krSk k)
+                              |  k <- view peerKeyring cred
+                              ,  view krPk k == pk
+                              ]) `orDie` "secret key not found"
 
-runNewGroupkey :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
+          gks <- pure (Symm.lookupGroupKey (snd sk) pk gk) `orDie` ("can't find secret key for " <> show (pretty (AsBase58 (fst sk))))
-runNewGroupkey pubkeysFile = do
+
+          let  segments :: S.Stream (S.Of ByteString) IO ()
+               segments = readChunked handle (fromIntegral defBlockSize)
+
+          let source = ToEncryptSymmBS gks segments gk
+
+          r <- runExceptT $ writeAsMerkle ss source
+
+          case r of
+            Left e  -> die (show e)
+            Right h -> print (pretty h)
+
+        Just (EncAsymm gk) -> do
+
+          accKeyh <- (putBlock ss . serialise . permitted . accessKey) gk
+              `orDie` "can not store access key"
+
+          let rawChunks :: S.Stream (S.Of ByteString) IO ()
+              rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
+
+              encryptedChunks :: S.Stream (S.Of ByteString) IO ()
+              encryptedChunks = rawChunks
+                  & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict)
+
+          mhash <- putAsMerkle ss encryptedChunks
+          mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash))
+              `orDie` "merkle tree was not stored properly with `putAsMerkle`"
+
+          mannh <- maybe (die "can not store MerkleAnn") pure
+                =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do
+              MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree
+
+          print $ "merkle-ann-root: " <+> pretty mannh
+
+runNewGroupKeyAsymm :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
+runNewGroupKeyAsymm pubkeysFile = do
   s <- BS.readFile pubkeysFile
   pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file"
   keypair <- newKeypair @s Nothing
@@ -414,14 +488,14 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "cat"             (info pCat (progDesc "cat block"))
                         <> command "hash"            (info pHash (progDesc "calculates hash"))
                         <> command "fsck"            (info pFsck (progDesc "check storage constistency"))
-                        <> command "deps"            ( info pDeps (progDesc "print dependencies"))
+                        <> command "deps"            (info pDeps (progDesc "print dependencies"))
-                        <> command "del"             ( info pDel (progDesc "del block"))
+                        <> command "del"             (info pDel (progDesc "del block"))
                         <> command "keyring-new"     (info pNewKey (progDesc "generates a new keyring"))
                         <> command "keyring-list"    (info pKeyList (progDesc "list public keys from keyring"))
                         <> command "keyring-key-add" (info pKeyAdd (progDesc "adds a new keypair into the keyring"))
                         <> command "keyring-key-del" (info pKeyDel (progDesc "removes a keypair from the keyring"))
                         <> command "show-peer-key"   (info pShowPeerKey (progDesc "show peer key from credential file"))
-                        <> command "groupkey-new"    (info pNewGroupkey (progDesc "generates a new groupkey"))
+                        <> command "groupkey"        (info pGroupKey (progDesc "group key commands"))
                         <> command "reflog"          (info pReflog (progDesc "reflog commands"))
                         <> command "bundle"          (info pBundle (progDesc "bundle commands"))
                         <> command "anyref"          (info pAnyRef (progDesc "anyref commands"))
@@ -435,9 +509,16 @@ main = join . customExecParser (prefs showHelpOnError) $
       o <- common
       file <- optional $ strArgument ( metavar "FILE" )
       init' <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit
-      groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" )
+      groupkeyFile <- optional $ strOption ( long "groupkey" <> short 'g' <> help "path to groupkey file" )
       b58meta <- optional $ strOption ( long "short-meta-base58" <> help "pass escaped metadata string")
-      pure $ withStore o (runStore ( StoreOpts init' file (OptGroupkeyFile <$> groupkeyFile) b58meta))
+      pk <- optional $ option epk ( long "public-key" <> short 'P' <> help "public key of group key")
+      kr <- optional $ strOption ( long "keyring" <> short 'k' <> help "keyring file") <&> OptKeyringFile
+      pure $ withStore o (runStore ( StoreOpts init' file (OptGroupkeyFile <$> groupkeyFile) b58meta pk kr))
+
+    epk  :: ReadM OptEncPubKey
+    epk = eitherReader $ \arg -> do
+      let mpk = fromStringMay @(PubKey 'Encrypt HBS2Basic) arg
+      maybe1 mpk (Left "invalid public key") (pure . OptEncPubKey)
 
     pCat = do
       o <- common
@@ -448,9 +529,42 @@ main = join . customExecParser (prefs showHelpOnError) $
       pure $ withStore o $ runCat
           $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw
 
-    pNewGroupkey = do
+    pGroupKey = hsubparser (  command "asymm" (info pGroupKeyAsymm (progDesc "asymmetric group keys") )
+                           <> command "symm"  (info pGroupKeySymm  (progDesc "symmetric group keys") )
+                           )
+
+
+    pGroupKeyAsymm = hsubparser (  command "gen" (info pGroupKeyAsymmNew (progDesc "generate") )
+                                )
+
+    pGroupKeyAsymmNew = do
       pubkeysFile <- strArgument ( metavar "FILE" <> help "path to a file with a list of recipient public keys" )
-      pure $ runNewGroupkey pubkeysFile
+      pure $ runNewGroupKeyAsymm pubkeysFile
+
+
+    pGroupKeySymm = hsubparser (  command "gen" (info pGroupKeySymmGen (progDesc "generate") )
+                               <> command "dump" (info pGroupKeySymmDump (progDesc "dump") )
+                               )
+
+    pGroupKeySymmGen = do
+      fn <- optional $ strArgument ( metavar "FILE" <> help "group key definition file" )
+      pure $ do
+        syn <- maybe1 fn getContents readFile <&> parseTop <&> fromRight mempty
+
+        let members = [ fromStringMay @(PubKey 'Encrypt HBS2Basic) (Text.unpack s)
+                      | (ListVal (Key "member" [LitStrVal s]) ) <- syn
+                      ] & catMaybes
+
+        gk <- Symm.generateGroupKey @HBS2Basic members
+        print $ pretty (AsGroupKeyFile gk)
+
+    pGroupKeySymmDump = do
+      fn <- optional $ strArgument ( metavar "FILE" <> help "group key file" )
+      pure $ do
+        gk <- ( maybe1 fn LBS.getContents LBS.readFile
+                <&> Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file"
+
+        print $ pretty gk
 
     pHash = do
       o <- common

hbs2/hbs2.cabal

@@ -79,12 +79,14 @@ executable hbs2
                     , interpolatedstring-perl6
                     , memory
                     , microlens-platform
+                    , mtl
                     , optparse-applicative
                     , prettyprinter
                     , safe
                     , saltine
                     , serialise
                     , streaming
+                    , suckless-conf
                     , text
                     , transformers
                     , uniplate