group-keys / repository-encryption to test

.fixme/log

@@ -1,2 +0,0 @@
-
-fixme-del "3PJf47D9oE"

docs/devlog.md

@@ -1,3 +1,22 @@
+## 2023-10-11
+
+запостили аннотацию с ключами.
+теперь пробуем её процессировать.
+
+и вот этот волнующий момент
+
+... тестируем, как работает удаление ключа.
+   - не работает пока что (почему?)
+
+... и еще раз тестируем удаление/добавление ключей
+
+## 2023-10-10
+
+Начинацию операем.
+
+Шаг 1. Выяснить, что нам вообще надо добавить нового автора
+
+
 ## 2023-10-08
 
 Конечно, грустно, что девлог превратился в черти-что.

docs/todo/git-encryption.planb

@@ -0,0 +1,29 @@
+
+;; Plan-B file
+
+;; исходный файл гипотетической утилиты для планирования
+;; когда я её сделаю? ну, после шифрования, наверное.
+;; пока будем тут планировать
+
+;; из этой штуки можно будет и TODO генерировать для fixme
+
+[ task keyinfo
+
+]
+
+[ plan
+
+  -> git-hbs2-tools-key-command
+  -> hbs2-config-parse
+  -> key-info
+  -> key-info-test
+  -> key-data
+  -> key-metadata
+  -> inject-key-metadata
+  -> handle-key-metadata
+  -> encrypt-git-log
+  -> decrypt-git-log
+  -> git-encryption-a1
+]
+
+

docs/todo/hbs2-git-private-repoes.txt

@@ -45,5 +45,23 @@ TODO: git-group-key
   hbs2-git не будет знать, какой ключ использовать.
 
 
+TODO: support-metadata-in-git-log-tree
+  Помещать метаданные в меркл-дерево журналов,
+  при первом прогоне для каждой новой транзакции
+  сначала обрабатывать метаданные, если они не обработаны,
+  вторым проходом обрабатывать уже сами транзы.
+
+
+TODO: tools:generate-group-key-for-ref
+  Добавить функцию генерации/перегенерации группового
+  ключа по KeyInfo.
+
+  1. Ключ отсутствует
+  2. Ключ присутствует, KeyInfo expired
+  3. Ключ присутствует, KeyInfo не expired
+
+
+TODO: tools:list-group-keys
+  Выводить имеющиеся ключи/шифрованные ссылки
 
 

flake.nix

@@ -71,6 +71,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
    shellExtBuildInputs = {pkgs}: with pkgs;  [
      haskellPackages.haskell-language-server
      haskellPackages.cbor-tool
+     haskellPackages.htags
      pkg-config
      inputs.hspup.packages.${pkgs.system}.default
      inputs.fixme.packages.${pkgs.system}.default

hbs2-core/lib/HBS2/Actors/Peer/Types.hs

@@ -25,19 +25,19 @@ instance {-# OVERLAPPABLE #-}
 -- instance HasConf m => HasConf (ResponseM e m)
 
 
-instance (IsKey HbSync) => Storage AnyStorage HbSync ByteString IO where
+instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m  where
-  putBlock (AnyStorage s) = putBlock s
+  putBlock (AnyStorage s) = liftIO . putBlock s
-  enqueueBlock (AnyStorage s) = enqueueBlock s
+  enqueueBlock (AnyStorage s) = liftIO . enqueueBlock s
-  getBlock (AnyStorage s) = getBlock s
+  getBlock (AnyStorage s) = liftIO . getBlock s
-  getChunk (AnyStorage s) = getChunk s
+  getChunk (AnyStorage s) h a b = liftIO $ getChunk s h a b
-  hasBlock (AnyStorage s) = hasBlock s
+  hasBlock (AnyStorage s) = liftIO . hasBlock s
-  updateRef (AnyStorage s) = updateRef s
+  updateRef (AnyStorage s) r v = liftIO $ updateRef s r v
-  getRef (AnyStorage s) = getRef s
+  getRef (AnyStorage s) = liftIO . getRef s
-  delBlock (AnyStorage s) = delBlock s
+  delBlock (AnyStorage s) = liftIO . delBlock s
-  delRef (AnyStorage s) = delRef s
+  delRef (AnyStorage s) = liftIO . delRef s
 
-data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
+data AnyStorage = forall zu  . ( Storage zu HbSync ByteString IO
-                              ) => AnyStorage zu
+                               ) => AnyStorage zu
 
 class HasStorage m where
   getStorage :: m AnyStorage

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

@@ -1,8 +1,13 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language TemplateHaskell #-}
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language ConstraintKinds #-}
-module HBS2.Net.Auth.GroupKeySymm where
+module HBS2.Net.Auth.GroupKeySymm
+  ( module HBS2.Net.Auth.GroupKeySymm
+  , module HBS2.Net.Proto.Types
+  , KeyringEntry(..), krPk, krSk
+  ) where
 
 import HBS2.Prelude.Plated
 import HBS2.Base58
@@ -17,9 +22,6 @@ 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
@@ -37,10 +39,9 @@ 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.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
 import Data.Maybe
 import Data.Word (Word64)
 import Data.ByteArray()
@@ -57,12 +58,25 @@ import Data.Bits (xor)
 
 type GroupSecretAsymm = Key
 
+-- NOTE: breaking-change
+
+-- NOTE: not-a-monoid
+--  это моноид, но опасный, потому, что секретные ключи у двух разных
+--  групповых ключей могут быть разными, и если
+--  просто объединить два словаря - какой-то секретный
+--  ключ может быть потерян. а что делать-то, с другой стороны?
 data instance GroupKey 'Symm s =
   GroupKeySymm
-  { recipients :: [(PubKey 'Encrypt s, EncryptedBox GroupSecretAsymm)]
+  { recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecretAsymm)
   }
   deriving stock (Generic)
 
+instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where
+  mempty = GroupKeySymm mempty
+
+instance ForGroupKeySymm s => Semigroup (GroupKey 'Symm s) where
+  (<>) (GroupKeySymm a) (GroupKeySymm b) = GroupKeySymm (a <> b)
+
 instance Serialise Key
 instance Serialise SK.Nonce
 
@@ -73,8 +87,9 @@ data instance ToEncrypt 'Symm s LBS.ByteString =
   , toEncryptNonce       :: BS.ByteString
   , toEncryptData        :: Stream (Of LBS.ByteString) IO ()
   , toEncryptGroupKey    :: GroupKey 'Symm s
+  , toEncryptMeta        :: AnnMetaData
   }
-
+  deriving (Generic)
 
 type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
                          , PubKey 'Encrypt s ~ AK.PublicKey
@@ -88,11 +103,16 @@ type ForGroupKeySymm s = ( Eq (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))
+  pretty g = vcat (fmap prettyEntry (HashMap.toList (recipients g)))
     where
       prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk))
 
 
+instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
+  fromStringMay s = runIdentity $ runMaybeT do
+    bs <- toMPlus $ fromBase58 $ B8.pack s
+    toMPlus $ deserialiseOrFail @(GroupKey 'Symm s) (LBS.fromStrict bs)
+
 instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where
   pretty (AsGroupKeyFile pc) =  "# hbs2 symmetric group key file"
                                 <> line <> co
@@ -109,10 +129,10 @@ parseGroupKey :: forall s . (ForGroupKeySymm s, Serialise (GroupKey 'Symm s))
 
 parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 (LBS8.toStrict bs)
 
-instance ( Serialise  (GroupKey 'Asymm s)
+instance ( Serialise  (GroupKey 'Symm s)
          )
 
-  =>  Pretty (AsBase58 (GroupKey 'Asymm s)) where
+  =>  Pretty (AsBase58 (GroupKey 'Symm s)) where
   pretty (AsBase58 c) =
     pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
 
@@ -121,11 +141,9 @@ generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m)
                  -> [PubKey 'Encrypt s]
                  -> m (GroupKey 'Symm s)
 
-generateGroupKey mbk pks' = GroupKeySymm <$> create
+generateGroupKey mbk pks = GroupKeySymm <$> create
   where
-    pks = List.sort (List.nub pks')
+    create = HashMap.fromList <$> do
-
-    create = do
       sk <- maybe1 mbk (liftIO SK.newKey) pure
       forM pks $ \pk -> do
         box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
@@ -138,7 +156,7 @@ lookupGroupKey :: ForGroupKeySymm s
                -> Maybe GroupSecretAsymm
 
 lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
-  (EncryptedBox bs) <- MaybeT $ pure $ List.lookup pk (recipients gk)
+  (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk)
   -- error  "FOUND SHIT!"
   gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs
   -- error $ "DECRYPTED SHIT!"
@@ -230,7 +248,7 @@ instance ( MonadIO m
 
     tree <- maybe (throwError StorageError) pure root
 
-    let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree
+    let ann = MTreeAnn (toEncryptMeta source) (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree
 
     putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure
 
@@ -243,31 +261,20 @@ instance ( MonadIO m
          , sch ~ HBS2Basic
          ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
 
-  data instance TreeKey (ToDecrypt 'Symm sch ByteString) = ToDecryptBS [KeyringEntry sch] (Hash HbSync)
+  data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
+      ToDecryptBS   [KeyringEntry sch] (Hash HbSync)
+    | ToDecryptBS2  (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTree [HashRef])
 
   type instance ToBlockR  (ToDecrypt 'Symm sch ByteString) = ByteString
   type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString
 
-  readFromMerkle sto (ToDecryptBS ke h) = do
+  readFromMerkle sto decrypt  = do
 
-    let keys = [ (view krPk x, view krSk x) | x <- ke ]
+    (keys, gk, nonceS, tree) <- decryptDataFrom decrypt
-
-    bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure
-    let what = tryDetect h bs
-
-    let tree' = case what of
-          MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n))
-          _ -> Nothing
-
-    (tree, (gkh,nonceS)) <- 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
+    gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
 
     let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec)
     let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
@@ -282,6 +289,7 @@ instance ( MonadIO m
       blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure
 
       let nonceI = nonceFrom (nonce0, i)
+
       let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk)
 
       maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
@@ -290,3 +298,28 @@ instance ( MonadIO m
     pure $ mconcat ss
 
 
+    where
+
+      decryptDataFrom = \case
+        ToDecryptBS2 gk nonce ke tree  -> do
+          let keys = [ (view krPk x, view krSk x) | x <- ke ]
+          pure (keys, gk, nonce, tree)
+
+        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 n}) -> Just (_mtaTree ann, (g,n))
+                _ -> Nothing
+
+          (tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure
+
+          gkbs <- readFromMerkle sto (SimpleKey gkh)
+
+          gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs)
+
+          pure (keys, gk, nonceS, tree)
+

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

@@ -22,7 +22,7 @@ import Data.ByteString (ByteString)
 import Type.Reflection (someTypeRep)
 import Lens.Micro.Platform
 
-newtype RefLogKey s = RefLogKey (PubKey 'Sign s)
+newtype RefLogKey s = RefLogKey { fromRefLogKey :: PubKey 'Sign s }
 
 deriving stock instance IsRefPubKey s => Eq (RefLogKey s)
 

hbs2-core/lib/HBS2/Prelude.hs

@@ -1,3 +1,4 @@
+{-# Language FunctionalDependencies #-}
 module HBS2.Prelude
   ( module Data.String
   , module Safe
@@ -6,6 +7,7 @@ module HBS2.Prelude
   , void, guard, when, unless
   , maybe1
   , eitherToMaybe
+  , ToMPlus(..)
   , Hashable
   , lift
   , AsFileName(..)
@@ -16,6 +18,7 @@ module HBS2.Prelude
   , ToByteString(..)
   , FromByteString(..)
   , Text.Text
+  , (&), (<&>)
   ) where
 
 import Data.Typeable as X
@@ -25,10 +28,13 @@ import Data.ByteString (ByteString)
 import Data.String (IsString(..))
 import Safe
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad (void,guard,when,unless)
+import Control.Monad (guard,when,unless,MonadPlus(..))
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe
 
+import Data.Kind
 import Data.Function
+import Data.Functor
 import Data.Char qualified as Char
 import Data.Text qualified as Text
 import Data.Hashable
@@ -62,3 +68,19 @@ class ToByteString a where
 
 class FromByteString a where
   fromByteString :: ByteString -> Maybe a
+
+
+class MonadPlus m => ToMPlus m a  where
+  type family ToMPlusResult a :: Type
+  toMPlus  :: a -> m (ToMPlusResult a)
+
+instance Monad m => ToMPlus (MaybeT m) (Maybe a) where
+  type instance ToMPlusResult (Maybe a) = a
+  toMPlus Nothing = mzero
+  toMPlus (Just a) = MaybeT (pure (Just a))
+
+instance Monad m => ToMPlus (MaybeT m) (Either x a) where
+  type instance ToMPlusResult (Either x a) = a
+  toMPlus (Left{}) = mzero
+  toMPlus (Right x) = MaybeT $ pure (Just x)
+

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

@@ -24,6 +24,8 @@ import Control.Monad.Except
 import Data.Bifunctor
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
+-- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
+-- importimport Data.List.Split (chunksOf)
 
 
 instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where
@@ -69,3 +71,19 @@ instance ( MonadIO m
     pure $ mconcat pieces
 
 
+readChunkedBS :: (Integral a, Monad m)
+              => ByteString
+              -> a
+              -> S.Stream (S.Of ByteString) m ()
+
+readChunkedBS bs size = foo bs
+  where
+    foo =
+      fix $ \loop leftover -> do
+        let (chunk, rest) = LBS.splitAt (fromIntegral size) leftover
+        unless (LBS.null chunk) do
+          S.yield chunk
+          loop rest
+
+
+

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

@@ -13,7 +13,7 @@ data OperationError =
   | DecryptionError
   | MissedBlockError
   | UnsupportedFormat
-  | GroupKeyNotFound
+  | GroupKeyNotFound Int
   deriving (Generic,Show,Data,Typeable)
 
 -- instance Exception OperationError

hbs2-git/examples/config/encrypted-ref

@@ -0,0 +1,18 @@
+rpc unix "/tmp/hbs2-rpc.socket"
+
+keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key"
+
+keyring "/home/dmz/w/hbs2/test1.key"
+keyring "/home/dmz/w/hbs2/test2.key"
+keyring "/home/dmz/w/hbs2/test3.key"
+keyring "/home/dmz/w/hbs2/test4.key"
+keyring "/home/dmz/w/hbs2/test5.key"
+
+[ encrypted "EDRuSaFmWbCnyUNtFbgCtqfiCrYPJvnY9pZB81AbSTbr"
+  (ttl 86400)
+  (owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
+  (member "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
+  (member "GcTjPEDSTCKNKnwPZWBjudeTqSie2fvYfsoSAzUKTRZ5")
+]
+
+

hbs2-git/examples/config/encrypted-ref-2

@@ -0,0 +1,30 @@
+rpc unix "/tmp/hbs2-rpc.socket"
+
+branch "master"
+branch "hbs2-git"
+
+keyring "/home/dmz/dmz-data/hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP.key"
+keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key"
+
+keyring "/home/dmz/w/hbs2/k5.key"
+
+;;keyring "/home/dmz/w/hbs2/test1.key"
+;;keyring "/home/dmz/w/hbs2/test2.key"
+;;keyring "/home/dmz/w/hbs2/test6.key"
+;; keyring "/home/dmz/w/hbs2/test3.key"
+
+decrypt "/home/dmz/w/hbs2/au11.key"
+decrypt "/home/dmz/w/hbs2/owner.key"
+decrypt "/home/dmz/w/hbs2/k5.key"
+
+[ encrypted "HFKuPTyaQLLmfgfVveu5GA4spt4c6oQBMUo1aeQ4abXG"
+  (ttl 86400)
+  (owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
+  (member "H9miZgHYg84wZM8Hu93t7iLHcKnZytAEgcB26LGbLTz4")
+  (member "2jsaezeu8iCRYBqMVBauCxnkHXvP3CkEFLeVxE8bRfvH")
+  (member "FNGD1oNh9AVXw1v7ZFpC5V2P2GGYRoUwnP6qwTw9JGpn")
+  (member "J2FWG3uib7TpZsu1k8sz8cekC3VH1ggNBhZKJxtUce4Q")
+  (member "E9WGzRzmD5G5SHbz9u7n3WKCz1eaVNPvT5f1NEKUQ6FU")
+  (keyring "/home/dmz/w/hbs2/owner.key")
+]
+

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -40,6 +40,7 @@ import Text.InterpolatedString.Perl6 (qc)
 import UnliftIO.IO as UIO
 import Control.Monad.Catch
 import Control.Monad.Trans.Resource
+import Lens.Micro.Platform
 
 
 send :: MonadIO m => BS.ByteString -> m ()
@@ -74,24 +75,48 @@ capabilities :: BS.ByteString
 capabilities = BS.unlines ["push","fetch"]
 
 
+getGlobalOptionFromURL :: HasGlobalOptions m => [String] -> m ()
+getGlobalOptionFromURL args = do
+
+  case args of
+    [_, ss] -> do
+      let (_, suff) = Text.breakOn "?" (Text.pack ss)
+                      & over _2 (Text.dropWhile (== '?'))
+                      & over _2 (Text.splitOn "&")
+                      & over _2 (fmap (over _2 (Text.dropWhile (=='=')) . Text.break (== '=')))
+                      & over _2 (filter (\(k,_) -> k /= ""))
+
+      forM_ suff $ \(k,v) -> do
+        addGlobalOption (Text.unpack k) (Text.unpack v)
+
+    _ -> pure ()
 
 loop :: forall m . ( MonadIO m
                    , MonadCatch m
                    , MonadUnliftIO m
                    , MonadMask m
-                   , HasProgress (RunWithConfig (GitRemoteApp m))
+                   , HasProgress m
-                   , HasStorage (RunWithConfig (GitRemoteApp m))
+                   , HasConf m
-                   , HasRPC (RunWithConfig (GitRemoteApp m))
+                   , HasStorage m
-                   ) => [String] -> GitRemoteApp m ()
+                   , HasRPC m
+                   , HasRefCredentials m
+                   , HasEncryptionKeys m
+                   , HasGlobalOptions m
+                   ) => [String] -> m ()
 loop args = do
 
   trace $ "args:" <+> pretty args
 
-  let ref' = case args of
+  ref <- case args of
-              [_, s] -> Text.stripPrefix "hbs2://" (Text.pack s) <&> fromString @RepoRef . Text.unpack
+            [_, ss] -> do
-              _      -> Nothing
+              let (s, _) = Text.breakOn "?" (Text.pack ss)
 
-  ref <- pure ref' `orDie` ("invalid reference: "  <> show args)
+              let r = Text.stripPrefix "hbs2://" s <&> fromString @RepoRef . Text.unpack
+
+              pure r `orDie` [qc|bad reference {args}||]
+
+            _  -> do
+                die [qc|bad reference: {args}|]
 
   trace $ "ref:" <+> pretty ref
 
@@ -230,10 +255,16 @@ main = do
 
   runWithRPC $ \rpc -> do
     env <- RemoteEnv <$> liftIO (newTVarIO mempty)
+                     <*> liftIO (newTVarIO mempty)
+                     <*> liftIO (newTVarIO mempty)
                      <*> pure rpc
 
     runRemoteM env do
-      loop args
+      runWithConfig syn $ do
+        getGlobalOptionFromURL args
+        loadCredentials mempty
+        loadKeys
+        loop args
 
   shutUp
 

hbs2-git/git-hbs2/GitRemotePush.hs

@@ -44,6 +44,11 @@ newtype RunWithConfig m a =
 runWithConfig :: MonadIO m => [Syntax C] -> RunWithConfig m a -> m a
 runWithConfig conf m = runReaderT (fromWithConf m) conf
 
+
+instance (Monad m, HasGlobalOptions m) => HasGlobalOptions (RunWithConfig m) where
+  addGlobalOption k v = lift $ addGlobalOption k v
+  getGlobalOption k = lift $ getGlobalOption k
+
 instance (Monad m, HasStorage m) => HasStorage (RunWithConfig m) where
   getStorage = lift getStorage
 
@@ -57,44 +62,43 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
   getCredentials = lift . getCredentials
   setCredentials r c = lift $ setCredentials r c
 
+
+instance MonadIO m => HasEncryptionKeys (RunWithConfig (GitRemoteApp m)) where
+  addEncryptionKey = lift . addEncryptionKey
+  findEncryptionKey = lift . findEncryptionKey
+  enumEncryptionKeys = lift enumEncryptionKeys
+
 push :: forall  m . ( MonadIO m
                     , MonadCatch m
-                    , HasProgress (RunWithConfig (GitRemoteApp m))
+                    , HasConf m
-                    , MonadMask (RunWithConfig (GitRemoteApp m))
+                    , HasRefCredentials m
-                    , HasStorage (RunWithConfig (GitRemoteApp m))
+                    , HasEncryptionKeys m
+                    , HasGlobalOptions m
+                    , HasStorage m
+                    , HasRPC m
                     , MonadUnliftIO m
                     , MonadMask m
                     )
 
-     => RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef)
+     => RepoRef -> [Maybe GitRef] -> m (Maybe GitRef)
-
 
 
 push remote what@[Just bFrom , Just br] = do
-  (_, syn) <- Config.configInit
 
-  dbPath <- makeDbPath remote
+  _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
-  db <- dbEnv dbPath
+  trace $ "PUSH PARAMS" <+> pretty what
-
+  gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|]
-  runWithConfig syn do
+  _ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh
-    _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
+  importRefLogNew False remote
-    loadCredentials mempty
+  pure (Just br)
-    trace $ "PUSH PARAMS" <+> pretty what
-    gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|]
-    _ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh
-    importRefLogNew False remote
-    pure (Just br)
 
 push remote [Nothing, Just br]  = do
-  (_, syn) <- Config.configInit
 
-  runWithConfig syn do
+  _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
-    _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
+  trace $ "deleting remote reference" <+> pretty br
-    loadCredentials mempty
+  exportRefDeleted () remote br
-    trace $ "deleting remote reference" <+> pretty br
+  importRefLogNew False remote
-    exportRefDeleted () remote br
+  pure (Just br)
-    importRefLogNew False remote
-    pure (Just br)
 
 push r w = do
   warn $ "ignoring weird push" <+> pretty w <+> pretty r

hbs2-git/git-hbs2/GitRemoteTypes.hs

@@ -4,7 +4,8 @@ module GitRemoteTypes where
 
 import HBS2.Prelude
 import HBS2.OrDie
-import HBS2.Net.Auth.Credentials (PeerCredentials)
+import HBS2.Net.Proto
+import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition()
 import HBS2.Peer.RPC.Client.StorageClient
 
@@ -20,6 +21,8 @@ import Control.Monad.Trans.Resource
 data RemoteEnv =
   RemoteEnv
   { _reCreds :: TVar (HashMap RepoRef (PeerCredentials Schema))
+  , _reKeys  :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema))
+  , _reOpts  :: TVar (HashMap String String)
   , _reRpc   :: RPCEndpoints
   }
 
@@ -48,6 +51,16 @@ instance Monad m => HasRPC (GitRemoteApp m) where
 runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a
 runRemoteM env m = runReaderT (fromRemoteApp m) env
 
+
+instance MonadIO m => HasGlobalOptions (GitRemoteApp m) where
+  addGlobalOption k v =
+    asks (view reOpts ) >>= \t -> liftIO $ atomically $
+      modifyTVar' t (HashMap.insert k v)
+
+  getGlobalOption k = do
+    hm <- asks (view reOpts) >>= liftIO . readTVarIO
+    pure (HashMap.lookup k hm)
+
 instance MonadIO m => HasRefCredentials (GitRemoteApp m) where
 
   setCredentials ref cred = do
@@ -56,8 +69,16 @@ instance MonadIO m => HasRefCredentials (GitRemoteApp m) where
 
   getCredentials ref = do
     hm <- asks (view reCreds) >>= liftIO . readTVarIO
-    pure (HashMap.lookup ref hm) `orDie` "keyring not set"
+    pure (HashMap.lookup ref hm) `orDie` "keyring not set (3)"
 
+instance MonadIO m => HasEncryptionKeys (GitRemoteApp m) where
+  addEncryptionKey ke = do
+    asks (view reKeys) >>= \t -> liftIO $ atomically do
+      modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke))
 
+  findEncryptionKey puk = (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk
 
+  enumEncryptionKeys = do
+    them <- (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList
+    pure $ [KeyringEntry k s Nothing | (k,s) <- them ]
 

hbs2-git/git-hbs2/Main.hs

@@ -1,13 +1,17 @@
 module Main where
 
 import HBS2.Prelude
+import HBS2.OrDie
 
 import HBS2Git.App
 import HBS2Git.Export
 import HBS2Git.ListRefs
+import HBS2Git.KeysCommand
+import HBS2.Net.Proto.Definition()
 
 import RunShow
 
+import Data.Functor
 import Options.Applicative as O
 import Control.Monad
 
@@ -24,6 +28,7 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "list-refs" (info pListRefs (progDesc "list refs"))
                         <> command "show"      (info pShow (progDesc "show various types of objects"))
                         <> command "tools"     (info pTools (progDesc "misc tools"))
+                        <> command "key"       (info pKeys (progDesc "manage keys"))
                         )
 
     pExport = do
@@ -57,3 +62,27 @@ main = join . customExecParser (prefs showHelpOnError) $
       ref  <- strArgument (metavar "HASH-REF")
       pure $ runApp WithLog (runToolsGetRefs ref)
 
+
+    pKeys = hsubparser (  command "list"   (info pKeysList    (progDesc "list keys for refs"))
+                       <> command "refs"   (info pKeyRefsList (progDesc "list encrypted refs"))
+                       <> command "update" (info pKeyUpdate   (progDesc "update key for the ref"))
+                       )
+
+
+    pKeyUpdate = do
+      ref <- strArgument (metavar "REF-KEY")
+      pure $ do
+        rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY"
+        runApp WithLog (runKeysUpdate rk)
+
+    pKeyRefsList = do
+      pure $ do
+        runApp WithLog runKeyRefsList
+
+    pKeysList = do
+      ref <- strArgument (metavar "REF-KEY")
+      pure $ do
+        rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY"
+        runApp WithLog (runKeysList rk)
+
+

hbs2-git/hbs2-git.cabal

@@ -70,6 +70,7 @@ common shared-properties
                , exceptions
                , filelock
                , filepath
+               , filepattern
                , hashable
                , http-conduit
                , interpolatedstring-perl6
@@ -102,15 +103,21 @@ library
 
     exposed-modules:
       HBS2.Git.Types
-      HBS2.Git.Local
+      HBS2Git.Alerts
-      HBS2.Git.Local.CLI
+      HBS2Git.Annotations
       HBS2Git.App
+      HBS2Git.KeysMetaData
       HBS2Git.Config
       HBS2Git.Evolve
       HBS2Git.Export
+      HBS2Git.Encryption
+      HBS2Git.Encryption.KeyInfo
       HBS2Git.GitRepoLog
       HBS2Git.Import
+      HBS2Git.KeysCommand
       HBS2Git.ListRefs
+      HBS2.Git.Local
+      HBS2.Git.Local.CLI
       HBS2Git.PrettyStuff
       HBS2Git.State
       HBS2Git.Types

hbs2-git/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

hbs2-git/lib/HBS2/Git/Types.hs

@@ -128,5 +128,7 @@ shutUp = do
   setLoggingOff @ERROR
   setLoggingOff @NOTICE
   setLoggingOff @TRACE
+  setLoggingOff @INFO
+  setLoggingOff @WARN
 
 

hbs2-git/lib/HBS2Git/Alerts.hs

@@ -0,0 +1,9 @@
+module HBS2Git.Alerts where
+
+import HBS2.Prelude
+
+import Text.InterpolatedString.Perl6 (qc)
+
+noKeyInfoMsg :: forall a . Pretty a => a -> String
+noKeyInfoMsg repo =
+  [qc|*** No KeyInfo found, maybe malformed 'encryption' section for {pretty repo} in config|]

hbs2-git/lib/HBS2Git/Annotations.hs

@@ -0,0 +1,24 @@
+module HBS2Git.Annotations where
+
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs
+
+import HBS2Git.Encryption
+
+import Codec.Serialise
+
+data Annotation =
+  GK1 HashRef (GroupKey 'Symm HBS2Basic)
+  deriving (Generic)
+
+data Annotations =
+    NoAnnotations
+  | SmallAnnotations [Annotation]
+  deriving (Generic)
+
+instance Serialise Annotation
+instance Serialise Annotations
+
+
+
+

hbs2-git/lib/HBS2Git/App.hs

@@ -5,10 +5,11 @@ module HBS2Git.App
   ( module HBS2Git.App
   , module HBS2Git.Types
   , HasStorage(..)
+  , HasConf(..)
   )
   where
 
-import HBS2.Prelude
+import HBS2.Prelude.Plated
 import HBS2.Actors.Peer.Types
 import HBS2.Data.Types.Refs
 import HBS2.Base58
@@ -16,7 +17,8 @@ import HBS2.OrDie
 import HBS2.Hash
 import HBS2.Clock
 import HBS2.Storage
-import HBS2.Storage.Operations.ByteString
+import HBS2.Storage.Operations.ByteString as OP
+import HBS2.Net.Auth.GroupKeySymm qualified as Symm
 import HBS2.System.Logger.Simple
 import HBS2.Merkle
 import HBS2.Git.Types
@@ -32,8 +34,12 @@ import HBS2.Peer.RPC.API.RefLog
 
 import HBS2Git.Types
 import HBS2Git.Config as Config
+import HBS2Git.State
+import HBS2Git.KeysMetaData
+import HBS2Git.Encryption
 import HBS2Git.Evolve
 import HBS2Git.PrettyStuff
+import HBS2Git.Alerts
 
 import Data.Maybe
 import Control.Monad.Trans.Maybe
@@ -41,7 +47,9 @@ import Data.Foldable
 import Data.Either
 import Control.Monad.Reader
 import Control.Monad.Trans.Resource
-import Control.Monad.Except (runExceptT,throwError)
+-- import Control.Monad.Except (runExceptT,throwError)
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Catch
 import Crypto.Saltine.Core.Sign qualified as Sign
 import Data.ByteString.Lazy.Char8 (ByteString)
 import Data.ByteString.Char8 qualified as B8
@@ -50,20 +58,22 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Lens.Micro.Platform
 import System.Directory
+import System.FilePattern.Directory
 -- import System.FilePath
 import System.FilePath
 import System.Process.Typed
 import Text.InterpolatedString.Perl6 (qc)
-import Network.HTTP.Simple
+-- import Network.HTTP.Simple
-import Network.HTTP.Types.Status
+-- import Network.HTTP.Types.Status
 import Control.Concurrent.STM (flushTQueue)
 import Codec.Serialise
 import Data.HashMap.Strict qualified as HashMap
+import Data.HashSet qualified as HashSet
 import Data.List qualified as List
 import Data.Text qualified as Text
 -- import Data.IORef
-import System.IO.Unsafe (unsafePerformIO)
+-- import System.IO.Unsafe (unsafePerformIO)
-import Data.Cache qualified as Cache
+-- import Data.Cache qualified as Cache
 -- import Control.Concurrent.Async
 import System.Environment
 
@@ -113,6 +123,16 @@ infoPrefix = toStderr
 
 data WithLog = NoLog | WithLog
 
+
+instance MonadIO m => HasGlobalOptions (App m) where
+  addGlobalOption k v =
+    asks (view appOpts ) >>= \t -> liftIO $ atomically $
+      modifyTVar' t (HashMap.insert k v)
+
+  getGlobalOption k = do
+    hm <- asks (view appOpts) >>= liftIO . readTVarIO
+    pure (HashMap.lookup k hm)
+
 instance MonadIO m => HasRefCredentials (App m) where
   setCredentials ref cred = do
     asks (view appRefCred) >>= \t -> liftIO $ atomically $
@@ -120,7 +140,18 @@ instance MonadIO m => HasRefCredentials (App m) where
 
   getCredentials ref = do
     hm <- asks (view appRefCred) >>= liftIO . readTVarIO
-    pure (HashMap.lookup ref hm) `orDie` "keyring not set"
+    pure (HashMap.lookup ref hm) `orDie` "keyring not set (1)"
+
+instance MonadIO m => HasEncryptionKeys (App m) where
+  addEncryptionKey ke = do
+    asks (view appKeys) >>= \t -> liftIO $ atomically do
+      modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke))
+
+  findEncryptionKey puk = (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk
+
+  enumEncryptionKeys = do
+    them <- (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList
+    pure $ [KeyringEntry k s Nothing | (k,s) <- them ]
 
 instance (Monad m, HasStorage m) => (HasStorage (ResourceT m)) where
   getStorage = lift getStorage
@@ -134,62 +165,6 @@ instance MonadIO m => HasRPC (App m) where
 withApp :: MonadIO m => AppEnv -> App m a -> m a
 withApp env m = runReaderT (fromApp m) env
 
-{-# NOINLINE hBS2PeerCatAPI #-}
-hBS2PeerCatAPI :: IORef (Maybe API)
-hBS2PeerCatAPI = unsafePerformIO (newIORef Nothing)
-
-detectHBS2PeerCatAPI :: MonadIO m => m API
-detectHBS2PeerCatAPI = do
-  -- FIXME: hardcoded-hbs2-peer
-
-  v <- liftIO $ readIORef hBS2PeerCatAPI
-
-  case v of
-    Just x -> pure x
-    Nothing -> do
-      (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|])
-
-      let dieMsg = "hbs2-peer is down or it's http is inactive"
-
-      let answ = parseTop (LBS.unpack o) & fromRight mempty
-
-      let po = headMay [ n | ListVal (Key "http-port:" [LitIntVal n]) <- answ  ]
-      -- shutUp
-
-      pnum <- pure po `orDie`  dieMsg
-
-      debug $ pretty "using http port" <+> pretty po
-
-      let api = [qc|http://localhost:{pnum}/cat|]
-
-      liftIO $ writeIORef hBS2PeerCatAPI (Just api)
-
-      pure api
-
-
-detectHBS2PeerSizeAPI :: MonadIO m => m API
-detectHBS2PeerSizeAPI = do
-  api <- detectHBS2PeerCatAPI
-  let new = Text.replace "/cat" "/size" $ Text.pack api
-  pure $ Text.unpack new
-
-detectHBS2PeerPutAPI :: MonadIO m => m API
-detectHBS2PeerPutAPI = do
-  api <- detectHBS2PeerCatAPI
-  let new = Text.replace "/cat" "/" $ Text.pack api
-  pure $ Text.unpack new
-
-detectHBS2PeerRefLogGetAPI :: MonadIO m => m API
-detectHBS2PeerRefLogGetAPI = do
-  api <- detectHBS2PeerCatAPI
-  let new = Text.replace "/cat" "/reflog" $ Text.pack api
-  pure $ Text.unpack new
-
-
-getAppStateDir :: forall m . MonadIO m => m FilePath
-getAppStateDir = liftIO $ getXdgDirectory XdgData Config.appName
-
-
 
 runWithRPC :: forall m . MonadUnliftIO m => (RPCEndpoints -> m ()) -> m ()
 runWithRPC action = do
@@ -276,8 +251,10 @@ runApp l m = do
 
   runWithRPC $ \rpc -> do
     mtCred <- liftIO $ newTVarIO mempty
-    let env = AppEnv pwd (pwd </> ".git") syn xdgstate mtCred rpc
+    mtKeys <- liftIO $ newTVarIO mempty
-    runReaderT (fromApp m) (set appRpc rpc env)
+    mtOpt <- liftIO $ newTVarIO mempty
+    let env = AppEnv pwd (pwd </> ".git") syn xdgstate mtCred mtKeys mtOpt rpc
+    runReaderT (fromApp (loadKeys >> m)) (set appRpc rpc env)
 
   debug $ vcat (fmap pretty syn)
 
@@ -347,7 +324,11 @@ calcRank h = fromMaybe 0 <$> runMaybeT do
   pure $ sum n
 
 postRefUpdate :: ( MonadIO m
+                 , MonadMask m
+                 , HasStorage m
+                 , HasConf m
                  , HasRefCredentials m
+                 , HasEncryptionKeys m
                  , HasRPC m
                  , IsRefPubKey Schema
                  )
@@ -362,7 +343,11 @@ postRefUpdate ref seqno hash = do
   cred <- getCredentials ref
   let pubk = view peerSignPk cred
   let privk = view peerSignSk cred
-  let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash)
+
+  ann <- genKeysAnnotations ref
+
+  --  вот прямо сюда ОЧЕНЬ удобно вставить метаданные для GK1
+  let tran = SequentialRef seqno (AnnotatedHashRef ann hash)
   let bs = serialise tran & LBS.toStrict
 
   msg <- makeRefLogUpdate @HBS2L4Proto pubk privk bs
@@ -373,17 +358,46 @@ postRefUpdate ref seqno hash = do
     >>= either (err . viaShow) (const $ pure ())
 
 
-storeObject :: (MonadIO m, HasStorage m, HasConf m)
+storeObject :: ( MonadIO m
-            => ByteString -> ByteString -> m (Maybe HashRef)
+               , MonadMask m
-storeObject = storeObjectRPC
+               , HasStorage m
+               , HasConf m
+               , HasRefCredentials m
+               , HasEncryptionKeys m
+               )
+            => RepoRef
+            -> ByteString
+            -> ByteString
+            -> m (Maybe HashRef)
+storeObject repo meta bs = do
+  encrypted <- isRefEncrypted (fromRefLogKey repo)
+  info $ "encrypted" <+> pretty repo <> colon <+> if encrypted then "yes" else "no"
+  storeObjectRPC encrypted repo meta bs
 
-storeObjectRPC :: (MonadIO m, HasStorage m)
+
-               => ByteString
+
+data WriteOp = WritePlain | WriteEncrypted B8.ByteString
+
+storeObjectRPC :: ( MonadIO m
+                  , MonadMask m
+                  , HasStorage m
+                  , HasConf m
+                  , HasRefCredentials m
+                  , HasEncryptionKeys m
+                  )
+               => Bool
+               -> RepoRef
+               -> ByteString
                -> ByteString
                -> m (Maybe HashRef)
-storeObjectRPC meta bs = do
+
+storeObjectRPC False repo meta bs = do
   sto <- getStorage
+  db <- makeDbPath repo >>= dbEnv
+
   runMaybeT do
+
+
     h <- liftIO $ writeAsMerkle sto bs
     let txt = LBS.unpack meta & Text.pack
     blk <- MaybeT $ liftIO $ getBlock sto h
@@ -392,15 +406,58 @@ storeObjectRPC meta bs = do
     mtree <- MaybeT $ deserialiseOrFail @(MTree [HashRef]) blk
                     & either (const $ pure  Nothing) (pure . Just)
 
+    -- TODO: upadte-metadata-right-here
     let ann = serialise (MTreeAnn (ShortMetadata txt) NullEncryption mtree)
     MaybeT $ liftIO $ putBlock sto ann <&> fmap HashRef
 
 
-makeDbPath :: MonadIO m => RepoRef -> m FilePath
+storeObjectRPC True repo meta bs = do
-makeDbPath h = do
+
-  state <- getAppStateDir
+  sto <- getStorage
-  liftIO $ createDirectoryIfMissing True state
+  db <- makeDbPath repo >>= dbEnv
-  pure $ state </> show (pretty (AsBase58 h))
+
+  runMaybeT do
+
+    let txt = LBS.unpack meta & Text.pack
+
+    ki <- lift $ getKeyInfo (fromRefLogKey repo) >>= maybe noKeyInfo pure
+    gkh0 <- withDB db $ stateGetLocalKey ki >>= maybe noKeyFound pure
+
+    gk0  <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh0)))
+               >>= either (const $ noKeyFound) (pure . deserialiseOrFail @(GroupKey 'Symm HBS2Basic))
+               >>= either (const $ noKeyFound) pure
+
+    let pk = keyInfoOwner ki
+
+    sk <- lift (findEncryptionKey pk) >>= maybe noKeyFound pure
+
+    gks <- maybe noKeyFound pure (Symm.lookupGroupKey sk pk gk0)
+
+    let nonce = hashObject @HbSync bs & serialise
+                                      & LBS.drop 2
+                                      & LBS.toStrict
+
+    let bsStream = readChunkedBS bs defBlockSize
+    let source = ToEncryptSymmBS gks nonce bsStream gk0 (ShortMetadata txt)
+
+    h <- runExceptT (writeAsMerkle sto source) >>= either (const cantWriteMerkle) pure
+
+    pure (HashRef h)
+
+  where
+
+    cantWriteMerkle :: forall a m . MonadIO m => m a
+    cantWriteMerkle = die "Can't write encrypted merkle tree"
+
+    noKeyFound :: forall a m . MonadIO m => m a
+    noKeyFound = do
+      liftIO $ hPutDoc stderr (red $ "No group key found for repo" <+> pretty repo <> line)
+      die "*** fatal"
+
+    noKeyInfo = do
+      liftIO $ hPutDoc stderr (red $ pretty (noKeyInfoMsg repo) <> line)
+      die "*** fatal"
+
 
 loadCredentials :: ( MonadIO m
                    , HasConf m
@@ -408,20 +465,23 @@ loadCredentials :: ( MonadIO m
                    ) => [FilePath] -> m ()
 loadCredentials fp = do
 
-  trace $ "loadCredentials" <+> pretty fp
+  debug $ "loadCredentials" <+> pretty fp
 
   krOpt' <- cfgValue @KeyRingFiles @(Set FilePath) <&> Set.toList
 
   let krOpt = List.nub $ fp <> krOpt'
 
-  when (null krOpt) do
+  void $ runMaybeT do
-    die "keyring not set"
 
-  for_ krOpt $ \fn -> do
+    when (null krOpt) do
-    (puk, cred) <- loadKeyring fn
+      debug "keyring not set (2)"
-    trace $ "got creds for" <+> pretty (AsBase58 puk)
+      mzero
-    setCredentials (RefLogKey puk) cred
+
-    pure ()
+    for_ krOpt $ \fn -> do
+      (puk, cred) <- loadKeyring fn
+      trace $ "got creds for" <+> pretty (AsBase58 puk)
+      lift $ setCredentials (RefLogKey puk) cred
+      pure ()
 
 loadCredentials' ::
     ( MonadIO m
@@ -429,16 +489,96 @@ loadCredentials' ::
     )
     => FilePath -> m Sign.PublicKey
 loadCredentials' fn = do
-    (puk, cred) <- loadKeyring fn
+    (puk, cred) <- runMaybeT (loadKeyring fn) `orDie` [qc|Can't load credentials {fn}|]
     trace $ "got creds for" <+> pretty (AsBase58 puk)
     setCredentials (RefLogKey puk) cred
     pure puk
 
-loadKeyring :: (MonadIO m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema)
+loadKeyring :: (MonadIO m, MonadPlus m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema)
 loadKeyring fn = do
     krData <- liftIO $ B8.readFile fn
-    cred <- pure (parseCredentials @Schema (AsCredFile krData)) `orDie` "bad keyring file"
+
-    let puk = view peerSignPk cred
+    let cred' = parseCredentials @Schema (AsCredFile krData)
-    pure (puk, cred)
+
+    maybe1 cred' mzero $ \cred -> do
+      let puk = view peerSignPk cred
+      pure (puk, cred)
 
 
+makeFilter :: String -> (String, [String])
+makeFilter = norm . over _1 sub1 . over _2 List.singleton . go ""
+  where
+    go pref ( cn : cs ) | cn `elem` "?*" = (p0, p1 <> p2)
+      where
+        (p0, p1) = splitFileName pref
+        p2 = cn : cs
+
+    go pref ( '/' : cn : cs ) | cn `elem` "?*" = (pref <> ['/'], cn : cs)
+
+    go pref ( c : cs ) = go (pref <> [c]) cs
+
+    go pref [] = (pref, "")
+
+    sub1 "" = "."
+    sub1 x = x
+
+    norm (xs, [""]) = (p1, [p2])
+      where
+        (p1, p2) = splitFileName xs
+
+    norm x = x
+
+loadKeys :: ( MonadIO m
+            , HasConf m
+            , HasEncryptionKeys m
+            , HasGlobalOptions m
+            ) => m ()
+loadKeys = do
+  conf <- getConf
+
+  trace $ "loadKeys"
+
+  kp <- liftIO $ lookupEnv "HBS2KEYS"
+
+  found1 <- findKeyFiles =<< liftIO (lookupEnv "HBS2KEYS")
+  found2 <- findKeyFiles =<< getGlobalOption "key"
+
+  found <- liftIO $ mapM canonicalizePath (found1 <> found2)
+
+  let enc = [ args | (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) <- conf ]
+
+  let owners  = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
+                | ListVal @C (Key "owner" [LitStrVal o]) <- universeBi enc
+                ] & catMaybes & HashSet.fromList
+
+
+  let members = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
+                | ListVal @C (Key "member" [LitStrVal o]) <- universeBi enc
+                ] & catMaybes & HashSet.fromList
+
+  let decrypt =  [ Text.unpack o
+                 | ListVal @C (Key "decrypt" [LitStrVal o]) <- conf
+                 ]
+
+  let keyrings = [ Text.unpack o | ListVal @C (Key "keyring" [LitStrVal o]) <- universeBi enc
+                 ] <> decrypt <> found
+                 & List.nub
+
+  forM_ keyrings $ \k -> void $ runMaybeT do
+    trace $ "loadKeys: keyring" <+> pretty k
+    (_, pc) <- loadKeyring k
+
+    forM_ (view peerKeyring pc) $ \ke -> do
+      let pk = view krPk  ke
+
+      trace $ "loadKeyring: key" <+> pretty (AsBase58 pk)
+      lift $ addEncryptionKey ke
+
+
+  where
+    findKeyFiles w = do
+        let flt = makeFilter <$> w
+        maybe1 flt (pure mempty) $
+          \(p, fmask) -> liftIO do
+            getDirectoryFiles p fmask <&> fmap (p</>)
+

hbs2-git/lib/HBS2Git/Config.hs

@@ -4,6 +4,7 @@ module HBS2Git.Config
   ) where
 
 import HBS2.Prelude
+import HBS2.Base58
 import HBS2.System.Logger.Simple
 import HBS2.OrDie
 
@@ -18,9 +19,6 @@ import System.FilePath
 import System.Directory
 
 import System.Environment
-import System.IO (stderr)
-
--- type C = MegaParsec
 
 appName :: FilePath
 appName = "hbs2-git"
@@ -57,6 +55,8 @@ configPath _ = liftIO do
   pwd <- liftIO getCurrentDirectory
   git <- findGitDir pwd
   byEnv <- lookupEnv "GIT_DIR"
+  -- hPrint stderr ("BY-ENV", byEnv)
+  -- hPrint stderr =<< getEnvironment
   path <- pure (git <|> byEnv) `orDie`  "*** hbs2-git: .git directory not found"
   pure (takeDirectory path </> ".hbs2")
 
@@ -70,11 +70,9 @@ data ConfigPathInfo = ConfigPathInfo {
 getConfigPathInfo :: MonadIO m => m ConfigPathInfo
 getConfigPathInfo = do
   trace "getConfigPathInfo"
-  gitDir <- findWorkingGitDir
+  confP <- configPath ""
-  pwd <- configPath "" <&> takeDirectory
+  let pwd = takeDirectory confP
-  confP <- configPath pwd
   let confFile = confP </> "config"
-  trace $ "git dir" <+> pretty gitDir
   trace $ "confPath:" <+> pretty confP
   pure ConfigPathInfo {
       configRepoParentDir = pwd,
@@ -100,3 +98,13 @@ configInit = liftIO do
 cookieFile :: MonadIO m => m FilePath
 cookieFile = configPath "" <&> (</> "cookie")
 
+getAppStateDir :: forall m . MonadIO m => m FilePath
+getAppStateDir = liftIO $ getXdgDirectory XdgData appName
+
+
+makeDbPath :: MonadIO m => RepoRef -> m FilePath
+makeDbPath h = do
+  state <- getAppStateDir
+  liftIO $ createDirectoryIfMissing True state
+  pure $ state </> show (pretty (AsBase58 h))
+

hbs2-git/lib/HBS2Git/Encryption.hs

@@ -0,0 +1,57 @@
+module HBS2Git.Encryption
+  ( module HBS2Git.Encryption
+  , module HBS2Git.Encryption.KeyInfo
+  , module HBS2.Net.Auth.GroupKeySymm
+  ) where
+
+import HBS2.Prelude.Plated
+
+import HBS2.Base58
+import HBS2.Net.Proto.Types hiding (Cookie)
+import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
+import HBS2.Net.Proto.Definition()
+
+
+import HBS2Git.Encryption.KeyInfo
+
+import Data.Config.Suckless.Syntax
+import Data.Config.Suckless.KeyValue
+
+import Data.Function
+import Data.HashSet qualified as HashSet
+import Data.Maybe
+import Data.Text qualified as Text
+import Data.Time.Clock.POSIX
+
+-- type ForEncryption ?
+
+isRefEncrypted :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m Bool
+isRefEncrypted ref = do
+  conf <- getConf
+
+  let ee = [ True
+           | (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : _))  <- conf
+           , fromStringMay (Text.unpack r) == Just ref
+           ]
+
+  -- liftIO $ hPutDoc stderr $ "isRefEncrypted" <+> pretty (AsBase58 ref) <+> pretty ee <+> pretty (not (null ee)) <> line
+
+  pure $ not $ null ee
+
+getKeyInfo :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m (Maybe KeyInfo)
+getKeyInfo ref = do
+  conf <- getConf
+
+  now <- liftIO getPOSIXTime
+  let every = [ keyInfoFrom now syn | syn <- conf
+              , isJust (keyInfoFrom now syn)
+              ] & catMaybes
+
+  pure (lastMay [ x | x <- every, keyInfoRef x == ref ])
+
+
+genGK0 :: (MonadIO m) => KeyInfo -> m (GroupKey 'Symm  HBS2Basic)
+genGK0 ki = generateGroupKey @HBS2Basic Nothing members
+  where
+    members = HashSet.toList ( keyInfoOwner ki `HashSet.insert` keyInfoMembers ki )
+

hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs

@@ -0,0 +1,55 @@
+module HBS2Git.Encryption.KeyInfo where
+
+import HBS2.Prelude.Plated
+import HBS2.Hash
+
+import HBS2.Net.Proto.Types hiding (Cookie)
+-- import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
+import HBS2.Net.Proto.Definition()
+
+import Data.Config.Suckless.Syntax
+import Data.Config.Suckless.KeyValue
+
+import Codec.Serialise
+import Data.HashSet
+import Data.HashSet qualified as HashSet
+import Data.Text qualified as Text
+import Data.Time.Clock.POSIX (POSIXTime)
+import Data.Maybe
+
+
+data KeyInfo =
+  KeyInfo
+  { keyInfoNonce   :: Integer
+  , keyInfoRef     :: PubKey 'Sign HBS2Basic
+  , keyInfoOwner   :: PubKey 'Encrypt HBS2Basic
+  , keyInfoMembers :: HashSet (PubKey 'Encrypt HBS2Basic)
+  }
+  deriving (Eq,Ord,Show,Generic)
+
+instance Serialise KeyInfo
+
+instance Hashed HbSync KeyInfo where
+  hashObject ki = hashObject (serialise ki)
+
+
+
+keyInfoFrom :: POSIXTime -> Syntax C -> Maybe KeyInfo
+keyInfoFrom t (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) =
+  KeyInfo <$> nonce
+          <*> ref
+          <*> owner
+          <*> members
+
+  where
+    nonce = Just $ maybe 0 (round t `div`) ttl
+    ref = fromStringMay  (Text.unpack r)
+    ttl = Just $ lastDef 86400 [ x | ListVal @C (Key "ttl" [LitIntVal x]) <- args ]
+    owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal @C (Key "owner" [LitStrVal o]) <- args ]
+    members = Just $ HashSet.fromList
+                   $ catMaybes
+                   [ fromStringMay (Text.unpack o) | ListVal @C (Key "member" [LitStrVal o]) <- args ]
+
+    -- keypath = lastMay [ Text.unpack p | ListVal @C (Key "keyring" [LitStrVal p]) <- args ]
+
+keyInfoFrom _ _ = Nothing

hbs2-git/lib/HBS2Git/Export.hs

@@ -14,7 +14,6 @@ import HBS2.Data.Types.Refs
 import HBS2.OrDie
 import HBS2.System.Logger.Simple
 import HBS2.Net.Proto.Definition()
-import HBS2.Clock
 import HBS2.Base58
 import HBS2.Net.Proto.RefLog
 
@@ -24,6 +23,7 @@ import HBS2.Git.Local.CLI
 import HBS2Git.App
 import HBS2Git.State
 import HBS2Git.Config
+import HBS2Git.KeysMetaData
 import HBS2Git.GitRepoLog
 import HBS2Git.PrettyStuff
 
@@ -77,6 +77,7 @@ exportRefDeleted :: forall  o m . ( MonadIO m
                                   , MonadUnliftIO m
                                   , HasConf m
                                   , HasRefCredentials m
+                                  , HasEncryptionKeys m
                                   , HasProgress m
                                   , HasStorage m
                                   , HasRPC m
@@ -131,7 +132,9 @@ exportRefDeleted _ repo ref = do
                             <> "type:" <+> "hbs2-git-push-log"
                             <> line
 
-  logMerkle <- storeObject meta content `orDie` [qc|Can't store push log|]
+  updateGK0  repo
+
+  logMerkle <- storeObject repo meta content `orDie` [qc|Can't store push log|]
   postRefUpdate repo 0 logMerkle
   pure logMerkle
 
@@ -155,6 +158,20 @@ newtype ExportT m a = ExportT { fromExportT :: ReaderT ExportEnv m a }
                                        , MonadThrow
                                        )
 
+instance (Monad m, HasStorage m) => HasStorage (ExportT m) where
+  getStorage = lift getStorage
+
+instance (Monad m, HasConf m) => HasConf (ExportT m) where
+  getConf = lift getConf
+
+instance (Monad m, HasRPC m) => HasRPC (ExportT m) where
+  getRPC = lift getRPC
+
+instance (Monad m, HasEncryptionKeys m) => HasEncryptionKeys (ExportT m) where
+  addEncryptionKey = lift . addEncryptionKey
+  findEncryptionKey k  = lift $ findEncryptionKey k
+  enumEncryptionKeys = lift enumEncryptionKeys
+
 withExportEnv :: MonadIO m => ExportEnv -> ExportT m a -> m a
 withExportEnv env f = runReaderT (fromExportT f) env
 
@@ -163,16 +180,18 @@ writeLogSegments :: forall m . ( MonadIO m
                                , HasRPC m
                                , MonadMask m
                                , HasRefCredentials m
+                               , HasEncryptionKeys m
                                , HasConf m
                                )
                  => ( Int -> m () )
+                 -> RepoRef
                  -> GitHash
                  -> [GitHash]
                  -> Int
                  -> [(GitLogEntry, LBS.ByteString)]
                  -> ExportT m [HashRef]
 
-writeLogSegments onProgress val objs chunkSize trailing = do
+writeLogSegments onProgress repo val objs chunkSize trailing = do
 
   db          <- asks $ view exportDB
   written     <- asks $ view exportWritten
@@ -233,7 +252,8 @@ writeLogSegments onProgress val objs chunkSize trailing = do
 
       let gzipped = compressWith compressOpts content
 
-      logMerkle <- lift $ storeObject meta gzipped `orDie` [qc|Can't store push log|]
+      -- let nonce = hashObject @HbSync (serialise segments)
+      logMerkle <- lift $ storeObject repo meta gzipped `orDie` [qc|Can't store push log|]
 
       trace $ "PUSH LOG HASH: " <+> pretty logMerkle
       trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle
@@ -250,6 +270,7 @@ exportRefOnly :: forall  o m . ( MonadIO m
                                , MonadUnliftIO m
                                , HasConf m
                                , HasRefCredentials m
+                               , HasEncryptionKeys m
                                , HasProgress m
                                , HasStorage m
                                , HasRPC m
@@ -275,6 +296,8 @@ exportRefOnly _ remote rfrom ref val = do
           h <- MaybeT $ readRef remote
           calcRank h
 
+  updateGK0 remote
+
   trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val
 
   -- 1. get max ref value for known REMOTE branch
@@ -362,10 +385,10 @@ exportRefOnly _ remote rfrom ref val = do
 
     -- we need context entries to determine log HEAD operation sequence
     -- so only the last section needs it alongwith headEntry
-    logz  <- lift $ withExportEnv env (writeLogSegments upd val objects batch [ (ctx, ctxBs)
+    logz  <- lift $ withExportEnv env (writeLogSegments upd remote val objects batch [ (ctx, ctxBs)
-                                                                              , (rank, rankBs)
+                                                                                     , (rank, rankBs)
-                                                                              , (headEntry, repoHeadStr)
+                                                                                     , (headEntry, repoHeadStr)
-                                                                              ])
+                                                                                     ])
 
     -- NOTE: отдаём только последнюю секцию лога,
     --       что бы оставить совместимость
@@ -373,6 +396,8 @@ exportRefOnly _ remote rfrom ref val = do
 
 ---
 
+
+
 runExport :: forall m . ( MonadIO m
                         , MonadUnliftIO m
                         , MonadCatch m
@@ -380,11 +405,13 @@ runExport :: forall m . ( MonadIO m
                         , MonadMask (App m)
                         , HasStorage (App m)
                         , HasRPC (App m)
+                        , HasEncryptionKeys (App m)
                         )
 
           => Maybe FilePath -> RepoRef -> App m ()
 runExport mfp repo = do
     loadCredentials (maybeToList mfp)
+    loadKeys
     let krf = fromMaybe "keyring-file" mfp & takeFileName
     runExport'' krf repo
 
@@ -397,12 +424,14 @@ runExport' :: forall m . ( MonadIO m
                         , MonadMask (App m)
                         , HasStorage (App m)
                         , HasRPC (App m)
+                        , HasEncryptionKeys (App m)
                         )
 
           => FilePath -> App m ()
 
 runExport' fp = do
     repo <- loadCredentials' fp
+    loadKeys
     runExport'' (takeFileName fp) (RefLogKey repo)
 
 ---

hbs2-git/lib/HBS2Git/Import.hs

@@ -7,6 +7,9 @@ import HBS2.OrDie
 import HBS2.System.Logger.Simple
 import HBS2.Merkle
 import HBS2.Hash
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString(TreeKey(..))
+import HBS2.Net.Auth.GroupKeySymm
 import HBS2.Net.Proto.RefLog
 import Text.InterpolatedString.Perl6 (qc)
 import HBS2.Data.Detect hiding (Blob)
@@ -14,7 +17,9 @@ import HBS2.Data.Detect hiding (Blob)
 import HBS2.Git.Local
 import HBS2Git.GitRepoLog
 import HBS2Git.App
+import HBS2Git.Config
 import HBS2Git.State
+import HBS2Git.KeysMetaData
 import HBS2.Git.Local.CLI
 
 import Data.Fixed
@@ -27,6 +32,7 @@ import Data.ByteString.Lazy.Char8 qualified as LBS
 import Lens.Micro.Platform
 import Data.Set qualified as Set
 import Codec.Serialise
+import Control.Monad.Except (runExceptT)
 import Control.Monad.Catch
 import Control.Monad.Trans.Resource
 import System.Directory
@@ -36,12 +42,13 @@ import System.IO (openBinaryFile)
 import System.FilePath.Posix
 import Data.HashMap.Strict qualified as HashMap
 import Data.Text qualified as Text
-import Data.Config.Suckless
 import Data.Either
 
 import Streaming.ByteString qualified as SB
 import Streaming.Zip qualified as SZip
 
+import HBS2Git.PrettyStuff
+
 data RunImportOpts =
   RunImportOpts
   { _runImportDry    :: Maybe Bool
@@ -114,6 +121,7 @@ importRefLogNew :: ( MonadIO m
                    , MonadCatch m
                    , MonadMask m
                    , HasStorage m
+                   , HasEncryptionKeys m
                    , HasImportOpts opts
                    )
                 => opts -> RepoRef -> m ()
@@ -122,6 +130,8 @@ importRefLogNew opts ref = runResourceT do
 
   let force = importForce opts
 
+  sto <- getStorage
+
   let myTempDir = "hbs-git"
   temp <- liftIO getCanonicalTemporaryDirectory
   (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
@@ -158,12 +168,22 @@ importRefLogNew opts ref = runResourceT do
       sp0 <- withDB db savepointNew
       withDB db $ savepointBegin sp0
 
+      -- TODO: scan-metadata-transactions-first
+      --   Сканируем транзы, обрабатываем транзакции с метаданными
+      --   Пишем транзакции с журналами, что бы обрабатывались следующим
+      --   проходом только они. Таким образом не меняется сложность.
+
+      decrypt <- lift enumEncryptionKeys
+
+      debug $ "Decrypt" <> vcat (fmap pretty decrypt)
+
+      -- TODO: exclude-metadata-transactions
       forM_ entries $ \e -> do
 
         missed <- lift $ readBlock e <&> isNothing
 
         when missed do
-          debug $ "MISSED BLOCK" <+> pretty e
+          warn $ "MISSED BLOCK" <+> pretty e
 
         let fname = show (pretty e)
         let fpath = dir </> fname
@@ -172,9 +192,14 @@ importRefLogNew opts ref = runResourceT do
 
         runMaybeT $ do
           bs <- MaybeT $ lift $ readBlock e
-          refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs & either (const Nothing) Just
+          refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs
-          payload <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just
+          payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd)
-          let (SequentialRef _ (AnnotatedHashRef _ h)) = payload
+
+          -- NOTE: good-place-to-process-hash-log-update-first
+          let (SequentialRef _ (AnnotatedHashRef ann' h)) = payload
+
+          forM_ ann' (withDB db . importKeysAnnotations ref e)
+
           trace $ "PUSH LOG HASH" <+> pretty h
 
           treeBs   <- MaybeT $ lift $ readBlock h
@@ -197,10 +222,43 @@ importRefLogNew opts ref = runResourceT do
 
           unless (here && not force) do
 
+            (src, enc) <- case something of
+
+              MerkleAnn (MTreeAnn _ sc@(EncryptGroupNaClSymm g nonce) tree) -> do
+
+                gk10' <- runExceptT $ readFromMerkle sto (SimpleKey g)
+
+                -- FIXME: nicer-error-handling
+                gk10'' <- either (const $ err ("GK0 not found:" <+> pretty g)  >> mzero) pure gk10'
+
+                gk10 <- toMPlus (deserialiseOrFail gk10'')
+
+                gk11 <- withDB db $ stateListGK1 (HashRef g)
+
+                let gk1 = mconcat $ gk10 : gk11
+
+                -- elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS decrypt (fromHashRef h))
+                elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS2 gk1 nonce decrypt tree)
+
+                case elbs of
+                  Left{} -> do
+                    let lock = toStringANSI $ red "x"
+                    hPutStrLn stderr [qc|import [{lock}] {pretty e}|]
+                    mzero
+
+                  Right lbs -> (,True) <$> pure do
+                    SB.fromLazy lbs
+                    pure (fromIntegral (LBS.length lbs))
+
+              -- FIXME: remove-debug
+              MerkleAnn{} -> pure (blockSource h, False)
+
+              _ -> pure (blockSource h, False)
+
             sz <- if gzipped then do
-              SB.toHandle fh $ SZip.gunzip (blockSource h)
+              SB.toHandle fh $ SZip.gunzip src
             else
-              SB.toHandle fh (blockSource h)
+              SB.toHandle fh src
 
             release keyFh
 
@@ -213,8 +271,10 @@ importRefLogNew opts ref = runResourceT do
             num <- liftIO $ readTVarIO tnum
             trace $ "LOG ENTRY COUNT" <+> pretty  num
 
+            let lock = toStringANSI $ if enc then yellow "@" else " "
+
             let pref = take 16 (show (pretty e))
-            let name = [qc|import {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|]
+            let name = [qc|import [{lock}] {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|]
 
             oMon  <- newProgressMonitor name  num
 

hbs2-git/lib/HBS2Git/KeysCommand.hs

@@ -0,0 +1,80 @@
+module HBS2Git.KeysCommand
+  ( module HBS2Git.KeysCommand
+  , module HBS2.Net.Proto.Types
+  , CryptoAction(..)
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.Base58
+import HBS2.OrDie
+import HBS2.Net.Proto.Types
+
+import HBS2Git.App
+import HBS2Git.Encryption
+import HBS2.System.Logger.Simple
+
+
+import Data.Function
+import Data.Time.Clock.POSIX
+import Data.Maybe
+
+
+runKeyRefsList :: (MonadIO m, HasConf m) => m ()
+runKeyRefsList = do
+  conf <- getConf
+
+  now <- liftIO getPOSIXTime
+
+  let every = [ keyInfoRef <$> keyInfoFrom now syn | syn <- conf
+              , isJust (keyInfoFrom now syn)
+              ] & catMaybes
+
+  liftIO $ print $ vcat (fmap (pretty . AsBase58) every)
+
+
+
+runKeysUpdate :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m ()
+runKeysUpdate ref = do
+  conf <- getConf
+
+  -- TODO: generate-GK0
+  --  generate basic key for OWNER only
+
+  now <- liftIO getPOSIXTime
+  let every = [ keyInfoFrom now syn | syn <- conf
+              , isJust (keyInfoFrom now syn)
+              ] & catMaybes
+
+  this <- pure (lastMay [ x | x <- every, keyInfoRef x == ref ])
+            `orDie` "Not found encrypted section for given ref"
+
+  gk0 <- generateGroupKey @HBS2Basic Nothing [keyInfoOwner this]
+
+  pure ()
+
+  -- now <- liftIO getPOSIXTime
+
+  -- let every = [ keyInfoFrom now syn | syn <- conf
+  --             , isJust (keyInfoFrom now syn)
+  --             ] & catMaybes
+
+  -- let keys = [ x | x <- every, keyInfoRef x == ref ]
+
+  -- info $ viaShow keys
+
+
+runKeysList :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m ()
+runKeysList ref = do
+  conf <- getConf
+
+  now <- liftIO getPOSIXTime
+
+  let every = [ keyInfoFrom now syn | syn <- conf
+              , isJust (keyInfoFrom now syn)
+              ] & catMaybes
+
+  let keys = [ x | x <- every, keyInfoRef x == ref ]
+
+  info $ viaShow keys
+
+

hbs2-git/lib/HBS2Git/KeysMetaData.hs

@@ -0,0 +1,266 @@
+module HBS2Git.KeysMetaData where
+
+import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Base58
+import HBS2.Data.Detect
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Net.Proto.RefLog
+import HBS2.OrDie
+import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Logger.Simple
+import HBS2.Net.Proto.Definition()
+
+import HBS2Git.Types
+import HBS2Git.Alerts
+import HBS2Git.Annotations
+import HBS2Git.Encryption
+import HBS2Git.State
+import HBS2Git.PrettyStuff
+import HBS2Git.Config
+
+import Codec.Serialise
+import Control.Monad
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Trans.Maybe
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Either
+import Data.HashMap.Strict qualified as HashMap
+import Data.HashSet qualified as HashSet
+import Data.List qualified as List
+import Data.Function (on)
+import Data.Maybe
+import Lens.Micro.Platform
+import Streaming.Prelude qualified as S
+import System.IO
+import Text.InterpolatedString.Perl6 (qc)
+
+
+updateGK0 :: forall m . ( MonadIO m
+                        -- , HasRPC m
+                        , MonadMask m
+                        , HasStorage m
+                        , HasConf m
+                        , HasEncryptionKeys m
+                        )
+                 => RepoRef
+                 -> m ()
+updateGK0 repo = void $ runMaybeT do
+
+  guard =<< lift (isRefEncrypted (fromRefLogKey repo))
+
+  db <- makeDbPath repo >>= dbEnv
+  -- FIXME: check-if-for-die-good-here
+  ki <- lift $ getKeyInfo (fromRefLogKey repo)
+          `orDie` noKeyInfoMsg repo
+
+  -- 2. Если нет GK0 или он expired
+  mbGk0Hash <- withDB db $ stateGetLocalKey ki
+
+  -- 2.1 Генерируем новый GK0
+  gk0Hash <- lift $ maybe1 mbGk0Hash (makeNewGK0 ki) pure
+
+  when (isNothing mbGk0Hash) do
+    liftIO $ hPutDoc stderr $ "New GK0" <+> pretty gk0Hash <> line
+
+  withDB db $ statePutLocalKey ki gk0Hash repo
+
+  debug  $ "GK0" <+> pretty gk0Hash
+
+  where
+    makeNewGK0 ki = do
+      sto <- getStorage
+      gk <- genGK0 ki <&> serialise
+      liftIO $ writeAsMerkle sto (gk :: ByteString) <&> HashRef
+
+genKeysAnnotations :: forall m . ( MonadIO m
+                                 , MonadMask m
+                                 , HasStorage m
+                                 , HasConf m
+                                 , HasEncryptionKeys m
+                                 )
+                 => RepoRef
+                 -> m (Maybe HashRef)
+
+genKeysAnnotations repo = do
+  sto <- getStorage
+
+  runMaybeT do
+
+    guard =<< lift (isRefEncrypted (fromRefLogKey repo))
+
+    db <- makeDbPath repo >>= dbEnv
+    -- TODO: generate-and-update-keys-metadata
+    -- 1. get GK0
+
+    ki <- lift $ getKeyInfo (fromRefLogKey repo)
+            `orDie` noKeyInfoMsg repo
+
+    gk0Hash <- withDB db $ stateGetLocalKey ki
+                `orDie` noKeyInfoMsg repo
+
+    let processedKey = serialise ("GENKEYMETADATA", gk0Hash)
+
+    isNewKey  <- withDB db $ not <$> stateGetProcessed processedKey
+
+    sp0 <- withDB db savepointNew
+    withDB db $ savepointBegin sp0
+
+    -- FIXME: excess-data-roundtrip
+    gk0newBs <- (runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gk0Hash))))
+                  `orDie` [qc|*** Can't load GK0 {pretty gk0Hash}, maybe storage failure|]
+
+    -- теперь нам надо как-то узнать, что ключ новый и нам надо обработать
+    -- новых читателей.
+    -- Вариант #1: писать авторов в стейт. если они не обработаны еще,
+    -- то обрабатывать.
+
+    -- 2.2 Генерируем новый GK1 ∀ members
+    -- FIXME: might-be-slow
+
+    guard isNewKey
+
+    -- notice $ "NEW KEY APPEARED" <+> pretty gk0Hash
+
+    h <- toMPlus =<< getRef sto (refAlias repo)
+
+    gk0hs <- HashSet.fromList <$> S.toList_ (findAllGK0 sto h)
+
+    let keySource = do
+          forM_ gk0hs $ \gkh -> void $ runMaybeT do
+            gbs <- toMPlus =<< runExceptT (readFromMerkle sto (SimpleKey gkh))
+            gk0 <- toMPlus $ deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gbs
+            -- TODO: decrypt-secret-right-here
+            lift $ S.yield (gkh, gk0)
+
+    allKeys <- S.toList_ keySource <&> HashMap.fromList
+
+    -- ∀ gk0:
+    --    - вытащить секрет (найти, кем расшифровать) recipients
+    --    - взять вообще всех recipients и сформировать новый GK1
+    --      для каждого из recipients из allKeys
+
+    -- взять все доступные пары ключей?
+    keys <- lift enumEncryptionKeys <&> fmap (\x -> (view krPk x, view krSk x))
+
+    new' <- forM (HashMap.toList allKeys) $ \(hx, gk0) -> do
+      let gksec' = [ lookupGroupKey sk pk gk0 | (pk,sk) <- keys ] & catMaybes & headMay
+      case gksec' of
+        Nothing  -> pure (Left hx)
+        Just sec -> pure $ Right (hx, gk0, sec)
+
+    let missed = lefts new'
+
+    forM_ missed $ \miss -> do
+      warn $ "new group key: unavailable keys for gk" <+> pretty miss
+
+    let new = rights new'
+
+    gk0new <- pure (deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gk0newBs)
+                `orDie` [qc|*** Malformed/corrupted group key {pretty gk0Hash}|]
+
+    let rcpt0 = recipients gk0new
+
+    gnew <- forM new $ \(hx, gk0, sec) -> do
+
+      -- TODO: test-if-key-removing-works
+      let newRcpt = (recipients gk0new & HashMap.keysSet)
+                     `HashSet.difference`
+                    (recipients gk0 & HashMap.keysSet)
+
+      let r1 = HashMap.keys $ recipients gk0 <> recipients gk0new
+
+      let r11 = [ x | x <- r1, HashMap.member x rcpt0 ]
+
+      gk1 <- generateGroupKey @HBS2Basic (Just sec) r11
+
+      pure (hx, newRcpt, gk1)
+
+    let nr = HashSet.unions $ fmap (view _2) gnew
+
+    ann <- if HashSet.null nr then do
+             pure mempty
+           else do
+            forM gnew $ \(gk0h, _, gk1) -> do
+              pure (GK1 (HashRef gk0h) gk1)
+
+
+    annHash <- if List.null ann then do
+                 pure Nothing
+               else do
+                 Just . HashRef <$> writeAsMerkle sto (serialise (SmallAnnotations ann))
+
+    debug $ "ANNOTATIONS" <+> pretty annHash
+
+    withDB db do
+      statePutProcessed processedKey
+      savepointRelease sp0
+
+    toMPlus annHash
+
+  where
+
+    -- FIXME: deepScan-ScanShallow-broken
+    -- TODO: deal-with-missed-blocks
+    findAllGK0 sto h = do
+        -- TODO: performance-memoize-possible
+        --   можно мемоизировать для h
+        deepScan ScanDeep (const none) h (getBlock sto) $ \hx -> do
+          void $ runMaybeT do
+            blk  <- toMPlus =<< getBlock sto hx
+            refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) blk
+            payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd)
+
+            let (SequentialRef _ (AnnotatedHashRef _ ht)) = payload
+
+            treeBs <- toMPlus =<< getBlock sto (fromHashRef ht)
+
+            enc <- toMPlus (deserialiseOrFail @(MTreeAnn [HashRef]) treeBs)
+                       <&> _mtaCrypt
+
+            case enc of
+              EncryptGroupNaClSymm g _  -> do
+                -- liftIO $ hPutDoc stderr $ "GK0 FOR" <+> pretty
+                lift $ S.yield g
+
+              _ -> pure ()
+
+
+importKeysAnnotations :: forall m . ( MonadIO m
+                                    , MonadMask m
+                                    , HasStorage m
+                                    )
+                 => RepoRef
+                 -> HashRef
+                 -> HashRef
+                 -> DB m ()
+
+importKeysAnnotations repo e href = do
+  sto <- lift getStorage
+  -- db <- makeDbPath repo >>= dbEnv
+  void $ runMaybeT do
+    -- liftIO $ hPutDoc stderr $ "GOT ANNOTATION" <+> pretty e <+> pretty href <> line
+    ebs <- runExceptT $ readFromMerkle sto (SimpleKey (fromHashRef href))
+    bs <- toMPlus ebs
+
+    anns <- toMPlus $ deserialiseOrFail @Annotations bs
+
+    let entries = case anns of
+                    SmallAnnotations e -> [ gk1 | gk1@(GK1{}) <- e ]
+                    _                  -> mempty
+
+
+    forM_ entries $ \(GK1 gk0h gk1) -> do
+
+      -- liftIO $ hPutDoc stderr $ "IMPORTING GK1 FOR" <+> pretty gk0h <> line
+
+      forM_ (HashMap.toList (recipients gk1)) $ \(pk,box) -> do
+        let gk1small = GroupKeySymm @HBS2Basic (HashMap.singleton pk box)
+        lift $ statePutGK1 gk0h pk gk1small
+
+

hbs2-git/lib/HBS2Git/ListRefs.hs

@@ -1,5 +1,7 @@
 module HBS2Git.ListRefs where
 
+import HBS2.Prelude
+
 import HBS2Git.Types
 import HBS2.Prelude
 import HBS2Git.App
@@ -9,6 +11,7 @@ import HBS2.System.Logger.Simple
 import HBS2.Git.Local.CLI
 import HBS2.Git.Types
 import HBS2Git.Import (importRefLogNew)
+import HBS2Git.Config
 import HBS2Git.State
 import HBS2Git.PrettyStuff
 

hbs2-git/lib/HBS2Git/PrettyStuff.hs

@@ -1,5 +1,9 @@
-module HBS2Git.PrettyStuff where
+module HBS2Git.PrettyStuff
+  ( module HBS2Git.PrettyStuff
+  , hPutDoc
+  ) where
 
+import Data.Text qualified as Text
 import Prettyprinter
 import Prettyprinter.Render.Terminal
 
@@ -9,9 +13,15 @@ green = annotate (color Green)
 yellow :: Doc AnsiStyle -> Doc AnsiStyle
 yellow = annotate (color Yellow)
 
-
 red :: Doc AnsiStyle -> Doc AnsiStyle
 red = annotate (color Red)
 
+blue :: Doc AnsiStyle -> Doc AnsiStyle
+blue = annotate (color Blue)
+
 section :: Doc ann
 section = line <> line
+
+toStringANSI :: Doc AnsiStyle -> String
+toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc
+

hbs2-git/lib/HBS2Git/State.hs

@@ -1,7 +1,11 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
 module HBS2Git.State where
 
 import HBS2.Prelude
+import HBS2.Base58
+import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
+
 import HBS2Git.Types
 import HBS2.Data.Types.Refs
 import HBS2.Git.Types
@@ -10,6 +14,7 @@ import HBS2.Hash
 import HBS2.System.Logger.Simple
 
 import HBS2Git.Config (cookieFile)
+import HBS2Git.Encryption
 
 import Control.Monad.Trans.Resource
 import Data.Functor
@@ -63,6 +68,19 @@ instance ToField GitObjectType where
 instance FromField HashRef where
   fromField = fmap fromString . fromField @String
 
+instance ToField (RefLogKey HBS2Basic) where
+  toField rk = toField (show (pretty rk))
+
+newtype Base58Field a = Base58Field { unBaseB8Field :: a }
+
+instance Pretty (AsBase58 a) => ToField (Base58Field a) where
+  toField (Base58Field a) = toField (show (pretty (AsBase58 a)))
+
+instance FromStringMaybe a => FromField (Base58Field a) where
+  fromField x =
+    fromField @String x
+      <&> fromStringMay @a
+      >>= maybe (fail "can't parse base58 value") (pure  . Base58Field)
 
 newtype DB m a =
   DB { fromDB :: ReaderT DBEnv m a }
@@ -216,6 +234,35 @@ stateInit = do
   );
   |]
 
+
+  liftIO $ execute_ conn [qc|
+  CREATE TABLE IF NOT EXISTS groupkeylocal
+  ( keyhash    text not null
+  , ref        text not null
+  , timestamp  DATETIME DEFAULT CURRENT_TIMESTAMP
+  , valuehash  text not null
+  , primary key (keyhash)
+  );
+  |]
+
+  liftIO $ execute_ conn [qc|
+  CREATE TABLE IF NOT EXISTS gk1
+  ( gk0        text not null
+  , pk         text not null
+  , gk1        text not null
+  , primary key (gk0, pk)
+  );
+  |]
+
+  liftIO $ execute_ conn [qc|
+  CREATE TABLE IF NOT EXISTS processed
+  ( hash    text not null
+  , cookie  text not null
+  , timestamp  DATETIME DEFAULT CURRENT_TIMESTAMP
+  , primary key (hash)
+  );
+  |]
+
   liftIO $ execute_ conn [qc|
   DROP VIEW IF EXISTS v_log_depth;
   |]
@@ -523,3 +570,89 @@ stateGenCookie = do
       pure cookie
 
 
+stateListLocalKeys :: MonadIO m => DB m [HashRef]
+stateListLocalKeys = do
+  undefined
+
+stateGetLocalKey :: MonadIO m
+                 => KeyInfo
+                 -> DB m (Maybe HashRef)
+stateGetLocalKey ki = do
+  conn <- stateConnection
+  let h = hashObject @HbSync ki & HashRef
+  liftIO $ query conn [qc|select valuehash from groupkeylocal where keyhash = ? limit 1|] (Only h)
+            <&> fmap fromOnly . listToMaybe
+
+statePutLocalKey :: MonadIO m
+                 => KeyInfo
+                 -> HashRef
+                 -> RefLogKey HBS2Basic
+                 -> DB m ()
+
+statePutLocalKey ki gkh reflog = do
+  conn <- stateConnection
+  let sql = [qc|
+  INSERT INTO groupkeylocal (keyhash, ref, valuehash)
+  VALUES (?,?,?)
+  ON CONFLICT (keyhash) DO UPDATE SET
+    ref = excluded.ref, valuehash = excluded.valuehash
+  |]
+
+  liftIO $ execute conn sql (HashRef (hashObject @HbSync ki), reflog, gkh)
+  pure ()
+
+
+statePutProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m ()
+statePutProcessed h = do
+  conn <- stateConnection
+  cookie <- asks (view dbCookie)
+  liftIO $ execute conn [qc|
+    insert into processed (hash, cookie) values (?, ?)
+    on conflict (hash) do nothing
+  |] (HashRef (hashObject @HbSync h), cookie)
+
+stateGetProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m Bool
+stateGetProcessed h = do
+  conn <- stateConnection
+  cookie <- asks (view dbCookie)
+  r <- liftIO $ query @_ @(Only Int) conn [qc|
+    select 1 from processed where hash = ? and cookie = ? limit 1
+  |] (HashRef (hashObject @HbSync h), cookie)
+  pure $ not $ null r
+
+
+statePutGK1 :: MonadIO m => HashRef
+            -> PubKey 'Encrypt HBS2Basic
+            -> GroupKey 'Symm HBS2Basic
+            -> DB m ()
+
+statePutGK1 gk0 pk gk1 = do
+  conn <- stateConnection
+  liftIO $ execute conn [qc|
+    insert into gk1 (gk0, pk, gk1) values (?, ?, ?)
+    on conflict (gk0, pk) do nothing
+  |] (gk0, Base58Field pk, Base58Field gk1)
+
+stateGetGK1 :: MonadIO m
+            => HashRef
+            -> PubKey 'Encrypt HBS2Basic
+            -> DB m (Maybe (GroupKey 'Symm HBS2Basic))
+
+stateGetGK1 gk0 pk = do
+  conn <- stateConnection
+  r <- liftIO $ query conn [qc|
+    select gk1 from gk1 where gk0 = ? and pk = ? limit 1
+  |] (gk0, Base58Field pk)
+  pure $ listToMaybe $ fmap (unBaseB8Field . fromOnly) r
+
+stateListGK1 :: MonadIO m
+            => HashRef
+            -> DB m [GroupKey 'Symm HBS2Basic]
+
+stateListGK1 gk0 = do
+  conn <- stateConnection
+  r <- liftIO $ query conn [qc|
+    select gk1 from gk1 where gk0 = ?
+  |] (Only gk0)
+  pure $ fmap (unBaseB8Field . fromOnly) r
+

hbs2-git/lib/HBS2Git/Types.hs

@@ -6,18 +6,19 @@ module HBS2Git.Types
   ( module HBS2Git.Types
   , module Control.Monad.IO.Class
   , HasStorage(..)
+  , HasConf(..)
   , AnyStorage(..)
+  , RefLogKey(..)
   )
   where
 
 import HBS2.Prelude.Plated
 import HBS2.Hash
-import HBS2.Base58
+import HBS2.Clock
 import HBS2.Git.Types
 import HBS2.Actors.Peer.Types (HasStorage(..),AnyStorage(..))
 import HBS2.Peer.RPC.Client.Unix hiding (Cookie)
 import HBS2.Net.Proto.RefLog (RefLogKey(..))
-import HBS2.Net.Proto.Types hiding (Cookie)
 import HBS2.Net.Auth.Credentials
 
 import HBS2.Peer.RPC.API.Peer
@@ -30,13 +31,9 @@ import Data.Config.Suckless
 
 import System.ProgressBar
 import System.Exit as Exit
-import Control.Monad.Trans.Maybe
 import Control.Applicative
 import Control.Monad.IO.Class
 import Control.Monad.Reader
-import Data.Text qualified as Text
-import Data.Text (Text)
-import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy.Char8 qualified as LBS
 import Database.SQLite.Simple (Connection)
 import Data.Char (isSpace)
@@ -44,14 +41,12 @@ import Data.List qualified as List
 import Lens.Micro.Platform
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
-import Codec.Serialise
 import Control.Concurrent.STM
 import System.IO qualified as IO
 import System.IO (Handle)
 import Data.Kind
 import Control.Monad.Catch
 import Control.Monad.IO.Unlift
-import Control.Monad.Trans.Resource
 
 import System.TimeIt
 
@@ -102,6 +97,8 @@ data AppEnv =
   , _appConf         :: [Syntax C]
   , _appStateDir     :: FilePath
   , _appRefCred      :: TVar (HashMap RepoRef (PeerCredentials Schema))
+  , _appKeys         :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema))
+  , _appOpts         :: TVar (HashMap String String)
   , _appRpc          :: RPCEndpoints
   }
 
@@ -184,6 +181,15 @@ class MonadIO m => HasRefCredentials m where
   getCredentials :: RepoRef -> m (PeerCredentials Schema)
   setCredentials :: RepoRef -> PeerCredentials Schema -> m ()
 
+class MonadIO m => HasGlobalOptions m where
+  addGlobalOption :: String -> String -> m ()
+  getGlobalOption :: String -> m (Maybe String)
+
+class MonadIO m => HasEncryptionKeys m where
+  addEncryptionKey  :: KeyringEntry Schema -> m ()
+  findEncryptionKey :: PubKey 'Encrypt Schema -> m (Maybe (PrivKey 'Encrypt Schema))
+  enumEncryptionKeys :: m [KeyringEntry Schema]
+
 newtype App m a =
   App { fromApp :: ReaderT AppEnv m a }
   deriving newtype ( Applicative
@@ -201,6 +207,7 @@ newtype App m a =
 instance MonadIO m => HasConf (App m) where
   getConf = asks (view appConf)
 
+
 hPrint :: (Show a, MonadIO m) => Handle -> a -> m ()
 hPrint h s = liftIO $ IO.hPrint h s
 
@@ -220,6 +227,7 @@ exitFailure = do
 die :: MonadIO m => String -> m a
 die s = do
   shutUp
+  pause @'Seconds 0.1
   liftIO $ Exit.die s
 
 traceTime :: MonadIO m => String -> m a -> m a

hbs2-tests/test/PrototypeGenericService.hs

@@ -41,9 +41,11 @@ instance HasProtocol UNIX  (ServiceProto MyServiceMethods1 UNIX) where
 -- instance (MonadIO m, HasProtocol UNIX (ServiceProto MyServiceMethods1 UNIX)) => HasTimeLimits UNIX (ServiceProto MyServiceMethods1 UNIX) m where
 --   tryLockForPeriod _ _ = pure True
 
+
+type instance Input Method1 = String
+type instance Output Method1 = String
+
 instance MonadIO m => HandleMethod m Method1 where
-  type instance Input Method1 = String
-  type instance Output Method1 = String
   handleMethod n = do
     debug $ "SERVICE1. METHOD1" <+> pretty n
     case n of
@@ -51,11 +53,12 @@ instance MonadIO m => HandleMethod m Method1 where
       "PECHEN" -> pure "TRESKI"
       _        -> pure "X3"
 
-instance MonadIO m => HandleMethod m Method2 where
-  type instance Input Method2 = ()
-  type instance Output Method2 = ()
-  handleMethod _ = pure ()
 
+type instance Input Method2 = ()
+type instance Output Method2 = ()
+
+instance MonadIO m => HandleMethod m Method2 where
+  handleMethod _ = pure ()
 
 instance (HasProtocol UNIX (ServiceProto api UNIX), MonadUnliftIO m)
   => HasDeferred UNIX (ServiceProto api UNIX) m where

hbs2/Main.hs

@@ -378,7 +378,7 @@ runStore opts ss = runResourceT do
 
             let segments = readChunked fh (fromIntegral defBlockSize)
 
-            let source = ToEncryptSymmBS gks nonce segments gk
+            let source = ToEncryptSymmBS gks nonce segments gk NoMetaData
 
             r <- runExceptT $ writeAsMerkle ss source
 
@@ -415,9 +415,10 @@ runNewGroupKeyAsymm pubkeysFile = do
       List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk
   print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey
 
-runNewKey :: forall s . (s ~ HBS2Basic) => IO ()
+runNewKey :: forall s . (s ~ HBS2Basic) => Int -> IO ()
-runNewKey = do
+runNewKey n = do
-  cred <- newCredentials @s
+  cred0 <- newCredentials @s
+  cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
   print $ pretty $ AsCredFile $ AsBase58 cred
 
 runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
@@ -649,7 +650,8 @@ main = join . customExecParser (prefs showHelpOnError) $
       pure $ withStore o $ runHash $ HashOpts hash
 
     pNewKey = do
-      pure runNewKey
+      n <- optional $ option auto ( short 'n' <> long "number")
+      pure $ runNewKey (fromMaybe 0 n)
 
     pShowPeerKey = do
       fp <- optional $ strArgument ( metavar "FILE" )