small-encrypted-block wip

docs/todo/hbs2-storage-weak-refs.txt

@@ -0,0 +1,43 @@
+TODO: storage-weak-refs
+  Сделать ссылки, которые удаляются по достижению каких-то событий (например, истечение ttl).
+  Полезно, что бы не разрастался периметр к моменту, когда заработает сборка мусора.
+  Нужно, например, что бы кэшировать групповые ключи, так как сейчас сложно
+  сделать чистые (детерминированные) групповые ключи, да это и опасно.
+
+  Кейс: сохраняем ссылку на ключ, как SomeRef например.
+
+  По истечению заданного ttl ссылка должна быть удалена.
+
+  Как, например?
+
+  1. Это свойство hbs2-storage, не hbs2-peer
+
+  2. Поддержать тип --- обёртку?
+     Например, сейчас для любого типа ключа вычисляется хэш,
+     и ссылка пишется.
+     Можно добавить какую-то обёртку с метаданными, что писалась
+     не только ссылка, но и метаданные, например:
+
+     data WithExpiration t a = WithExpiration t a
+
+     instance Hashed (WithExpiration t a) where
+      hash (WithExpiration t a) = hash a
+
+     внутри сторейджа собирать метаданные в формате
+     [(String,String)] и писать в некий файл
+
+     A/X.metadata в виде:
+
+     key: value
+     key: value
+     key: value
+
+  3. Тогда при чтении (?) или время от временени:
+
+     читаем метаданные, смотрим, если ссылка протухла
+     --- то удаляем её.
+
+
+
+
+

hbs2-core/hbs2-core.cabal

@@ -88,6 +88,7 @@ library
                     , HBS2.Data.Types.Refs
                     , HBS2.Data.Types.SignedBox
                     , HBS2.Data.Types.EncryptedBox
+                    , HBS2.Data.Types.SmallEncryptedBlock
                     , HBS2.Data.Bundle
                     , HBS2.Defaults
                     , HBS2.Events

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

@@ -2,6 +2,7 @@ module HBS2.Data.Types
   ( module X
   -- , module HBS2.Data.Types.Crypto
   , AsSyntax(..)
+  , LoadedRef(..)
   )
   where
 
@@ -16,3 +17,4 @@ import HBS2.Data.Types.Peer as X
 
 newtype AsSyntax c = AsSyntax c
 
+

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

@@ -11,8 +11,14 @@ import HBS2.Net.Proto.Types
 import HBS2.Prelude
 
 import Codec.Serialise(serialise)
+import Data.Map (Map)
+import Data.Map qualified as Map
 import Data.Data
 
+class RefMetaData a where
+  refMetaData :: a -> [(String, String)]
+  refMetaData = const mempty
+
 newtype HashRef = HashRef { fromHashRef :: Hash HbSync }
                   deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync)
                   deriving stock (Data,Generic,Show)
@@ -72,6 +78,8 @@ type ForSomeRefKey a = ( Hashed HbSync a )
 
 newtype SomeRefKey a = SomeRefKey a
 
+instance RefMetaData (SomeRefKey a)
+
 instance Hashed HbSync (SomeRefKey a)  => Pretty (SomeRefKey a) where
   pretty a = pretty $ hashObject @HbSync a
 -- instance Hashed HbSync (SomeRefKey a) => Pretty (AsBase58 (SomeRefKey a)) where
@@ -88,8 +96,25 @@ newtype RefAlias = RefAlias { unRefAlias :: HashRef }
 instance Hashed HbSync RefAlias  where
   hashObject (RefAlias h) = fromHashRef h
 
+refAlias :: (Hashed HbSync ref, RefMetaData ref) => ref -> RefAlias2
+refAlias x = RefAlias2 (Map.fromList $ refMetaData x) (HashRef $ hashObject @HbSync x)
 
-refAlias :: Hashed HbSync ref => ref -> RefAlias
+data RefAlias2  =
-refAlias x = RefAlias (HashRef $ hashObject @HbSync x)
+  RefAlias2 { unRefAliasMeta :: Map String String
+            , unRefAlias2    :: HashRef
+            }
+  deriving stock (Eq,Ord,Show,Generic)
 
+instance Hashed HbSync RefAlias2  where
+  hashObject (RefAlias2 _ h) = fromHashRef h
+
+instance Serialise RefAlias2
+
+instance Pretty RefAlias2 where
+  pretty (RefAlias2 _ h) = pretty h
+
+instance RefMetaData RefAlias2 where
+  refMetaData x = Map.toList (unRefAliasMeta x)
+
+type LoadedRef a = Either HashRef a
 

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

@@ -0,0 +1,20 @@
+module HBS2.Data.Types.SmallEncryptedBlock where
+
+
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.EncryptedBox
+
+import Data.ByteString (ByteString)
+import Codec.Serialise
+
+data SmallEncryptedBlock t =
+  SmallEncryptedBlock
+  { sebGK0   :: HashRef     -- ^ gk0
+  , sebNonce :: ByteString
+  , sebBox   :: EncryptedBox t
+  }
+  deriving stock (Generic)
+
+instance Serialise  (SmallEncryptedBlock t)
+

hbs2-core/lib/HBS2/Hash.hs

@@ -42,7 +42,7 @@ type family HashType ( a :: Type) where
 type HbSyncHash = HashType HbSync
 
 newtype instance Hash HbSync =
-  HbSyncHash ByteString
+  HbSyncHash { fromHbSyncHash :: ByteString }
   deriving stock (Eq,Ord,Data,Generic)
   deriving newtype (Hashable,Show)
 

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

@@ -3,6 +3,7 @@
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language ConstraintKinds #-}
+{-# Language PatternSynonyms #-}
 module HBS2.Net.Auth.Credentials
   ( module HBS2.Net.Auth.Credentials
   ) where
@@ -55,6 +56,9 @@ data KeyringEntry e =
   }
   deriving stock (Generic)
 
+pattern KeyringKeys :: forall {s} . PubKey 'Encrypt s -> PrivKey 'Encrypt s -> KeyringEntry s
+pattern KeyringKeys a b <- KeyringEntry a b _
+
 deriving stock instance (Eq (PubKey 'Encrypt e), Eq (PrivKey 'Encrypt e))
   => Eq (KeyringEntry e)
 
@@ -72,6 +76,7 @@ makeLenses 'PeerCredentials
 type ForHBS2Basic s = ( Signatures s
                       , PrivKey 'Sign s ~ Sign.SecretKey
                       , PubKey 'Sign s ~ Sign.PublicKey
+                      , Eq (PubKey 'Encrypt HBS2Basic)
                       , IsEncoding (PubKey 'Encrypt s)
                       , Eq (PubKey 'Encrypt HBS2Basic)
                       , s ~ HBS2Basic

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

@@ -11,6 +11,7 @@ module HBS2.Net.Auth.GroupKeySymm
 import HBS2.Prelude.Plated
 import HBS2.Base58
 import HBS2.Data.Types.EncryptedBox
+import HBS2.Data.Types.SmallEncryptedBlock
 import HBS2.Data.Types.Refs
 import HBS2.Hash
 import HBS2.Merkle
@@ -57,7 +58,7 @@ import System.IO.Unsafe (unsafePerformIO)
 
 import Data.Bits (xor)
 
-type GroupSecretAsymm = Key
+type GroupSecret = Key
 
 
 -- NOTE: breaking-change
@@ -69,7 +70,7 @@ type GroupSecretAsymm = Key
 --  ключ может быть потерян. а что делать-то, с другой стороны?
 data instance GroupKey 'Symm s =
   GroupKeySymm
-  { recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecretAsymm)
+  { recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecret)
   }
   deriving stock (Generic)
 
@@ -85,10 +86,10 @@ instance Serialise SK.Nonce
 -- NOTE: hardcoded-hbs2-basic-auth-type
 data instance ToEncrypt 'Symm s LBS.ByteString =
   ToEncryptSymmBS
-  { toEncryptSecret      :: GroupSecretAsymm
+  { toEncryptSecret      :: GroupSecret
+  , toEncryptGroupKey    :: LoadedRef (GroupKey 'Symm s)
   , toEncryptNonce       :: BS.ByteString
   , toEncryptData        :: Stream (Of LBS.ByteString) IO ()
-  , toEncryptGroupKey    :: GroupKey 'Symm s
   , toEncryptMeta        :: AnnMetaData
   , toEncryptOpts        :: Maybe EncryptGroupNaClSymmOpts
   }
@@ -98,7 +99,7 @@ type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
                          , PubKey 'Encrypt s ~ AK.PublicKey
                          , PrivKey 'Encrypt s ~ AK.SecretKey
                          , Serialise (PubKey 'Encrypt s)
-                         , Serialise GroupSecretAsymm
+                         , Serialise GroupSecret
                          , Serialise SK.Nonce
                          , FromStringMaybe (PubKey 'Encrypt s)
                          )
@@ -139,8 +140,9 @@ instance ( Serialise  (GroupKey 'Symm s)
   pretty (AsBase58 c) =
     pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
 
+
 generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m)
-                 => Maybe GroupSecretAsymm
+                 => Maybe GroupSecret
                  -> [PubKey 'Encrypt s]
                  -> m (GroupKey 'Symm s)
 
@@ -152,11 +154,30 @@ generateGroupKey mbk pks = GroupKeySymm <$> create
         box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
         pure (pk, box)
 
+
+generateGroupKeyPure :: forall s nonce . (ForGroupKeySymm s, NonceFrom SK.Nonce nonce)
+                 => GroupSecret
+                 -> nonce
+                 -> [PubKey 'Encrypt s]
+                 -> GroupKey 'Symm s
+
+generateGroupKeyPure sec nonce pks = GroupKeySymm gk0
+  where
+    nonce0 = nonceFrom @SK.Nonce nonce
+    gk0 = undefined
+    -- gk0 = [ AK.box
+    -- HashMap.fromList <$> do
+    --   sk <- maybe1 mbk (liftIO SK.newKey) pure
+    --   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
+               -> Maybe GroupSecret
 
 lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
   (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk)
@@ -216,7 +237,7 @@ instance ( MonadIO m
 
     let nonce0 = nonceFrom @SK.Nonce (toEncryptNonce source)
 
-    gkh <- writeAsMerkle sto (serialise gk) <&> HashRef
+    gkh <- either pure (\k -> HashRef <$> writeAsMerkle sto (serialise k)) gk
 
     let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode key)
 
@@ -351,3 +372,74 @@ instance ( MonadIO m
 
           pure (keys, gk, nonceS, tree)
 
+
+
+encryptBlock :: ( MonadIO m
+                , Storage sto h ByteString m
+                , ForGroupKeySymm s
+                , Serialise t
+                , h ~ HbSync
+                )
+             => sto
+             -> GroupSecret
+             -> LoadedRef (GroupKey 'Symm s)
+             -> Maybe BS.ByteString           -- ^ nonce
+             -> t
+             -> m (SmallEncryptedBlock t)
+
+encryptBlock sto gks gk mnonce x = do
+
+  nonceS <- maybe (liftIO AK.newNonce <&> Saltine.encode) pure mnonce
+
+  let nonce0 = nonceFrom @SK.Nonce nonceS
+
+  gkh <- either pure (\k -> HashRef <$> writeAsMerkle sto (serialise k)) gk
+
+  let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gks)
+
+  let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
+
+  let encrypted = SK.secretbox key0 nonce0  (serialise x & LBS.toStrict)
+
+  pure $ SmallEncryptedBlock gkh nonceS (EncryptedBox encrypted)
+
+decryptBlock :: forall t s sto h m . ( MonadIO m
+                                     , MonadError OperationError m
+                                     , Storage sto h ByteString m
+                                     , ForGroupKeySymm s
+                                     , h ~ HbSync
+                                     , Serialise t
+                                     )
+
+             => sto
+             -> [KeyringEntry s]
+             -> SmallEncryptedBlock t
+             -> m t
+
+decryptBlock sto keys (SmallEncryptedBlock{..}) = do
+
+  gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0))
+  gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs)
+
+  let gksec' = [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay
+
+  gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
+
+  let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec)
+  let key0 = HKDF.expand prk sebNonce typicalKeyLength & Saltine.decode & fromJust
+  let nonce0 = nonceFrom @SK.Nonce sebNonce
+
+  let unboxed = SK.secretboxOpen key0 nonce0 (unEncryptedBox sebBox)
+
+  lbs <- maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
+
+  either (const $ throwError UnsupportedFormat) pure (deserialiseOrFail lbs)
+
+
+deriveGroupSecret :: NonceFrom SK.Nonce n => n -> BS.ByteString -> GroupSecret
+deriveGroupSecret n bs = key0
+  where
+    nonceS = nonceFrom @SK.Nonce n & Saltine.encode & hashObject @HbSync & fromHbSyncHash
+    prk = HKDF.extractSkip @_ @HbSyncHash bs
+    key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
+

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

@@ -12,6 +12,8 @@ import Data.Hashable hiding (Hashed)
 
 newtype AnyRefKey t s = AnyRefKey (PubKey 'Sign s)
 
+instance RefMetaData (AnyRefKey t s)
+
 deriving stock instance IsRefPubKey s => Eq (AnyRefKey n s)
 
 instance (IsRefPubKey s) => Hashable (AnyRefKey t s) where

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

@@ -124,6 +124,8 @@ instance Expires (SessionKey L4Proto (RefChanHeadBlock L4Proto)) where
 
 newtype RefChanHeadKey s = RefChanHeadKey (PubKey 'Sign s)
 
+instance RefMetaData (RefChanHeadKey s)
+
 deriving stock instance IsRefPubKey s => Eq (RefChanHeadKey s)
 
 instance IsRefPubKey s => Hashable (RefChanHeadKey s) where
@@ -147,6 +149,8 @@ instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (RefChanHeadKey s) where
 
 newtype RefChanLogKey s = RefChanLogKey { fromRefChanLogKey :: PubKey 'Sign s }
 
+instance RefMetaData (RefChanLogKey s)
+
 deriving stock instance IsRefPubKey s => Eq (RefChanLogKey s)
 
 instance IsRefPubKey s => Hashable (RefChanLogKey s) where

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

@@ -27,6 +27,8 @@ import Lens.Micro.Platform
 newtype RefLogKey s = RefLogKey { fromRefLogKey :: PubKey 'Sign s }
                       deriving stock Generic
 
+instance RefMetaData (RefLogKey s)
+
 instance Serialise (PubKey 'Sign s) => Serialise (RefLogKey s)
 
 deriving stock instance IsRefPubKey s => Eq (RefLogKey s)

hbs2-core/lib/HBS2/OrDie.hs

@@ -1,8 +1,12 @@
-module HBS2.OrDie where
+module HBS2.OrDie
+  ( module HBS2.OrDie
+  ) where
 
 import Data.Kind
 import Control.Monad.IO.Class
 import System.Exit
+import Prettyprinter
+import UnliftIO
 
 class OrDie m a where
   type family OrDieResult a :: Type
@@ -28,3 +32,31 @@ instance MonadIO m => OrDie m ExitCode where
   orDie mv err = mv >>= \case
     ExitSuccess   -> pure ()
     ExitFailure{} -> liftIO $ die err
+
+
+-- TODO: move-to-library
+class OrThrow a  where
+  type family OrThrowResult a :: Type
+  orThrow :: forall e m  . (MonadIO m, Exception e) =>  e -> a -> m (OrThrowResult a)
+
+instance OrThrow (Maybe a) where
+  type instance OrThrowResult (Maybe a) = a
+  orThrow e a = case a of
+    Nothing -> throwIO e
+    Just x  -> pure x
+
+
+instance OrThrow (Either b a) where
+  type instance OrThrowResult (Either b a) = a
+  orThrow e a = case a of
+    Left{}  -> throwIO e
+    Right x -> pure x
+
+orThrowUser :: (OrThrow a1, MonadIO m)
+            => Doc ann
+            -> a1
+            -> m (OrThrowResult a1)
+
+orThrowUser p = orThrow (userError (show p))
+
+

hbs2-core/lib/HBS2/Storage.hs

@@ -1,13 +1,16 @@
 {-# Language FunctionalDependencies #-}
+{-# Language DefaultSignatures #-}
 module HBS2.Storage where
 
-import HBS2.Hash
 import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Data.Types.Refs (RefMetaData(..))
 
 import Data.Kind
 import Lens.Micro.Platform
 import Data.ByteString.Lazy (ByteString)
 import Control.Monad.Trans.Maybe
+import Data.Word
 
 import Codec.Serialise()
 
@@ -29,6 +32,12 @@ newtype Size = Size Integer
                deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty,Serialise)
                deriving stock (Show)
 
+data ExpiredAfter a = ExpiredAfter Word64 a
+                      deriving stock (Generic)
+
+instance Serialise a => Serialise (ExpiredAfter a)
+
+
 class ( Monad m
       , IsKey h
       , Hashed h block
@@ -46,11 +55,11 @@ class ( Monad m
 
   hasBlock :: a -> Key h -> m (Maybe Integer)
 
-  updateRef :: Hashed h k => a -> k -> Key h -> m ()
+  updateRef :: (Hashed h k, RefMetaData k) => a -> k -> Key h -> m ()
 
-  getRef :: (Hashed h k, Pretty k) => a -> k -> m (Maybe (Key h))
+  getRef :: (Hashed h k, Pretty k, RefMetaData k) => a -> k -> m (Maybe (Key h))
 
-  delRef :: Hashed h k => a -> k -> m ()
+  delRef :: (Hashed h k, RefMetaData k) => a -> k -> m ()
 
 
 data AnyStorage = forall zu  . ( Storage zu HbSync ByteString IO
@@ -59,10 +68,14 @@ data AnyStorage = forall zu  . ( Storage zu HbSync ByteString IO
 class HasStorage m where
   getStorage :: m AnyStorage
 
-
 instance (Monad m, HasStorage m) => HasStorage (MaybeT m) where
   getStorage = lift getStorage
 
+instance Hashed h a => Hashed h (ExpiredAfter a) where
+  hashObject (ExpiredAfter _ a) = hashObject a
+
+instance RefMetaData a => RefMetaData (ExpiredAfter a) where
+  refMetaData (ExpiredAfter t x) = [("expires", show t)] <> refMetaData x
 
 instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m  where
   putBlock (AnyStorage s) = liftIO . putBlock s

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

@@ -22,7 +22,6 @@ class (MonadIO m, Storage storage hash (ToBlockW s) m) => MerkleWriter s hash st
   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

hbs2-git/lib/HBS2Git/App.hs

@@ -453,7 +453,13 @@ storeObjectRPC True repo meta bs = do
                                       & LBS.toStrict
 
     let bsStream = readChunkedBS bs defBlockSize
-    let source = ToEncryptSymmBS gks nonce bsStream gk0 (ShortMetadata txt) Nothing
+
+    let source = ToEncryptSymmBS gks
+                                 (Left gkh0 :: LoadedRef (GroupKey 'Symm HBS2Basic))
+                                 nonce
+                                 bsStream
+                                 (ShortMetadata txt)
+                                 Nothing
 
     h <- runExceptT (writeAsMerkle sto source) >>= either (const cantWriteMerkle) pure
 

hbs2-peer/app/Brains.hs

@@ -50,6 +50,10 @@ import UnliftIO (MonadUnliftIO(..),async,race)
 data PeerBrainsDb
 
 
+-- TODO: refactor-brains
+--   переключить на db-pipe
+--   асинки - в runContT
+
 -- FIXME: move-that-orphans-somewhere
 
 instance ToField HashRef where

hbs2-peer/app/CLI/Common.hs

@@ -1,6 +1,7 @@
 {-# Language TemplateHaskell #-}
 module CLI.Common where
 
+import HBS2.Clock
 import HBS2.Net.Messaging.Unix
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Service
@@ -33,4 +34,15 @@ withMyRPC o m = do
   let soname = getRpcSocketName conf
   withRPC2 @api  @UNIX soname m
 
+withRPCMessaging :: MonadIO m => RPCOpt -> (MessagingUnix  -> m ()) -> m ()
+withRPCMessaging o action = do
+  conf  <- peerConfigRead (view rpcOptConf o)
+  let soname = getRpcSocketName conf
+  client1 <- newMessagingUnix False 1.0 soname
+  m1 <- liftIO $ async $ runMessagingUnix client1
+  link m1
+  action client1
+  pause @'Seconds 0.05
+  cancel m1
+
 

hbs2-peer/app/CLI/RefChan.hs

@@ -2,15 +2,26 @@ module CLI.RefChan where
 
 import HBS2.Prelude.Plated
 
+import HBS2.Hash
+import HBS2.Clock
 import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Credentials.Sigil
 import HBS2.Net.Proto.Definition()
 import HBS2.Net.Proto.RefChan
 import HBS2.Net.Proto.Types
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Actors.Peer.Types
 import HBS2.Data.Types.SignedBox
 import HBS2.Net.Proto.Service
 import HBS2.Data.Detect
 import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
 import HBS2.Data.Types.Refs
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Auth.GroupKeySymm
+
+import HBS2.KeyMan.Keys.Direct
 
 import HBS2.OrDie
 
@@ -22,13 +33,27 @@ import HBS2.Peer.RefChanNotifyLog
 import CLI.Common
 import RPC2()
 
-import Options.Applicative
+import HBS2.System.Logger.Simple hiding (info)
-import Data.ByteString qualified as BS
+import HBS2.System.Logger.Simple qualified as Log
-import Data.ByteString.Lazy qualified as LBS
+
-import Lens.Micro.Platform
+import Control.Monad.Cont
-import Data.Maybe
+import Control.Monad.Reader
-import System.Exit
 import Control.Monad.Trans.Maybe
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Data.HashSet qualified as HashSet
+import Data.Maybe
+import Lens.Micro.Platform
+import Options.Applicative
+import System.Exit
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Control.Monad.Except (runExceptT)
+import Data.Word
+import Codec.Serialise
+import UnliftIO
+import Streaming.Prelude qualified as S
+
 
 pRefChan :: Parser (IO ())
 pRefChan = hsubparser (   command "head" (info pRefChanHead (progDesc "head commands" ))
@@ -36,6 +61,7 @@ pRefChan = hsubparser (   command "head" (info pRefChanHead (progDesc "head comm
                        <> command "notify"  (info pRefChanNotify (progDesc "post notify message"))
                        <> command "fetch"   (info pRefChanFetch (progDesc "fetch and sync refchan value"))
                        <> command "get"     (info pRefChanGet (progDesc "get refchan value"))
+                       <> command "gk"      (info pRefChanGK  (progDesc "generate a group key"))
                       )
 
 
@@ -138,19 +164,150 @@ pRefChanNotify =
              <> command  "tail"  (info pRefChanNotifyLogTail (progDesc  "output last messages"))
              )
 
+data EncMethod = EncryptWithSigil FilePath
+               | NoEncryption
+
 pRefChanNotifyPost :: Parser (IO ())
 pRefChanNotifyPost = do
   opts <- pRpcCommon
-  kra <- strOption (long "author" <> short 'a' <> help "author credentials")
-  fn  <- optional $ strOption (long "file" <> short 'f' <> help "file")
-  puk <- argument pRefChanId (metavar "REFCHAH-REF")
-  pure $ withMyRPC @RefChanAPI opts $ \caller -> do
-    sc <- BS.readFile kra
-    creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
-    lbs <- maybe1 fn LBS.getContents LBS.readFile
-    let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs)
-    void $ callService @RpcRefChanNotify caller (puk, box)
 
+  si  <- strOption (long "sigil" <> short 's' <> help "sigil file")
+  fn   <- optional $ strOption (long "file" <> short 'f' <> help "file")
+
+  encrypt  <- encryptOpt
+  -- EncMethod <$> optional (switch (long "encrypt" <> help "encrypt transaction"))
+  --                       <*> optional (strOption (long "sigil" <> help "using sigil"))
+
+  puk <- argument pRefChanId (metavar "REFCHAH-REF")
+
+  pure $ flip runContT pure do
+
+    client <- ContT $ withRPCMessaging opts
+
+    self <- runReaderT (ownPeer @UNIX) client
+    refChanAPI  <- makeServiceCaller @RefChanAPI self
+    storageAPI  <- makeServiceCaller @StorageAPI self
+
+    let endpoints = [ Endpoint @UNIX refChanAPI
+                    , Endpoint @UNIX storageAPI
+                    ]
+
+    void $ ContT $ bracket (async $ runReaderT (runServiceClientMulti endpoints) client) cancel
+
+    -- caller <- ContT $ withMyRPC @RefChanAPI opts
+
+    sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58 @(Sigil L4Proto))
+                        `orDie` "parse sigil failed"
+
+    (auPk, sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil))
+                   >>= orThrowUser "malformed sigil/bad signature"
+
+    keys <- liftIO $ runKeymanClient do
+              creds  <- loadCredentials auPk >>= orThrowUser "can't load credentials"
+              encKey <- loadKeyRingEntry (sigilDataEncKey sd)
+              pure (creds,encKey)
+
+    let creds = view _1 keys
+
+    lbs <- liftIO $ maybe1 fn LBS.getContents LBS.readFile
+
+    let sto = AnyStorage (StorageClient storageAPI)
+
+    ss <- if not encrypt then do
+            pure lbs
+          else do
+            -- итак нам тут нужно знать:
+            --   2.   старый gk или новый
+            --   2.1  если старый - то где взять
+            --   2.2  стоит обновить gk или нет
+            --   2.3  стоит сохранять gk или нет
+            --
+            --   допустим так: ключ равно: голова + эпоха + enc SigilData
+            --
+            --   тогда: 1) где его хранить? в кеймане или в стейте?
+            --
+            --   + в кеймане, допустим?
+            --   в кеймане может быть блокировка sqlite, нехорошо
+
+            -- можно сохранять в hbs2:
+            --   1. групповой ключ и так там сохраняется
+            --   2. ссылок не должно быть много, если
+            --      ссылка ~ hash(канал, ключ пользователя)
+            --   3. обновление ключа:  если явно сказано!
+            --      иначе -- берём существующий
+            --   4. если голова поменялась -- можем
+            --      удалить ссылку?
+
+            kre@(KeyringKeys pk sk) <- orThrowUser "encryption key not found for given sigil" (view _2 keys)
+            let kreHash = hashObject @HbSync (serialise kre)
+
+            hh <- callService @RpcRefChanHeadGet refChanAPI puk
+                    >>= orThrowUser "RPC error"
+                    >>= orThrowUser "refchan head not available"
+
+            hd <- getRefChanHead @L4Proto sto (RefChanHeadKey puk)
+                    >>= orThrowUser "head block not found"
+
+            let rcpts = view refChanHeadReaders hd
+
+            when ( HashSet.null rcpts ) do
+              throwIO (userError "empty recipients list -- encryption is not possible")
+
+            notice $ "refchan head" <+> pretty hh
+
+            -- FIXME: key-rotation-factor-hardcode
+            --   около раза в месяц. может, нормально и так
+            t <- liftIO $ getPOSIXTime <&> round
+
+            let gkkey0 = SomeRefKey (hh,kreHash)
+
+            notice $ "gkkey0" <+> pretty (hashObject @HbSync gkkey0)
+
+            mgk <- runMaybeT do
+                    gkv <- toMPlus =<< getRef sto gkkey0
+
+                    notice $ "FOUND REF VAL" <+> pretty gkv
+
+                    gks <- runExceptT (readFromMerkle sto (SimpleKey gkv))
+                             >>= toMPlus
+
+                    gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gks
+                            & toMPlus
+
+                    notice $ "found GK0" <+> pretty gkv
+
+                    pure gk
+
+            gk <- case mgk of
+                    Just x -> pure x
+                    Nothing -> do
+                      gknew <- generateGroupKey @HBS2Basic Nothing (HashSet.toList rcpts)
+
+                      gkh <- writeAsMerkle sto (serialise gknew)
+
+                      -- FIXME: key-expiration-hardcode
+                      let gkkey1 = ExpiredAfter (t+1209600) gkkey0
+
+                      notice $ "UPDATE REF" <+> pretty (hashObject @HbSync gkkey1) <+> pretty gkh
+                      updateRef sto gkkey1  gkh
+
+                      notice $ "generated! GK0" <+> pretty gkh
+
+                      pure gknew
+
+            gks <- orThrowUser "can't decrypt group key" $ lookupGroupKey sk pk gk
+            -- FIXME: use-deterministic-nonce
+            lift $ encryptBlock sto gks (Right gk) Nothing lbs <&> serialise
+
+    let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict ss)
+    void $ callService @RpcRefChanNotify refChanAPI (puk, box)
+
+  where
+    encryptOpt = do
+      optional (switch (long "encrypt" <> help "post encrypted")) <&> fromMaybe False
+
+    -- noEncryption = pure NoEncryption
+    -- encryptWithSigil = EncryptWithSigil <$> strOption (long "sigil" <> help "sigil file")
 
 pRefChanId :: ReadM (RefChanId L4Proto)
 pRefChanId = maybeReader (fromStringMay @(RefChanId L4Proto))
@@ -204,3 +361,32 @@ pRefChanFetch = do
     void $ callService @RpcRefChanFetch caller href
 
 
+pRefChanGK :: Parser (IO ())
+pRefChanGK = do
+  opts <- pRpcCommon
+  puk <- argument pRefChanId (metavar "REFCHAH-REF")
+  pure $ flip runContT pure do
+
+    client <- ContT $ withRPCMessaging opts
+
+    self <- runReaderT (ownPeer @UNIX) client
+    refChanAPI  <- makeServiceCaller @RefChanAPI self
+    storageAPI  <- makeServiceCaller @StorageAPI self
+
+    let endpoints = [ Endpoint @UNIX refChanAPI
+                    , Endpoint @UNIX storageAPI
+                    ]
+
+    void $ ContT $ bracket (async $ runReaderT (runServiceClientMulti endpoints) client) cancel
+
+    let sto = AnyStorage (StorageClient storageAPI)
+
+    hd <- getRefChanHead @L4Proto sto (RefChanHeadKey puk)
+           >>= orThrowUser "head block not found"
+
+    let readers = view refChanHeadReaders' hd
+
+    gk <- generateGroupKey @HBS2Basic Nothing (HashSet.toList readers)
+
+    liftIO $ print $ pretty (AsGroupKeyFile gk)
+

hbs2-peer/hbs2-peer.cabal

@@ -18,7 +18,7 @@ common warnings
 
 common common-deps
     build-depends:
-          base, hbs2-core, hbs2-storage-simple
+          base, hbs2-core, hbs2-storage-simple, hbs2-keyman
         , aeson
         , async
         , bytestring
@@ -198,7 +198,7 @@ executable hbs2-peer
                     , CLI.RefChan
 
     -- other-extensions:
-    build-depends:    base, hbs2-peer
+    build-depends:    base, hbs2-peer, hbs2-keyman
 
     hs-source-dirs:   app
 

hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs

@@ -1,6 +1,8 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module HBS2.Peer.RPC.API.Storage where
 
+import HBS2.Prelude
+import HBS2.Data.Types.Refs
 import HBS2.Actors.Peer
 import HBS2.Net.Proto.Service
 import HBS2.Net.Messaging.Unix
@@ -8,6 +10,7 @@ import HBS2.Peer.RPC.Internal.Types
 import HBS2.Storage
 import HBS2.Data.Types.Refs (HashRef(..),RefAlias(..))
 
+import Control.Applicative
 import Control.Monad.Reader
 import Data.ByteString.Lazy (ByteString)
 import Codec.Serialise
@@ -36,10 +39,9 @@ type StorageAPI = '[ RpcStorageHasBlock
 instance HasProtocol UNIX  (ServiceProto StorageAPI UNIX) where
   type instance ProtocolId (ServiceProto StorageAPI UNIX) = 0xDA2374610001
   type instance Encoded UNIX = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode lbs = eitherToMaybe $ deserialiseOrFail lbs
   encode = serialise
 
-
 instance (Monad m)
   => HasRpcContext StorageAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where
   getRpcContext = lift ask
@@ -65,12 +67,12 @@ type instance Output RpcStorageDelBlock = ()
 type instance Input RpcStorageGetChunk = (HashRef, Offset, Size)
 type instance Output RpcStorageGetChunk = Maybe ByteString
 
-type instance Input RpcStorageGetRef = RefAlias
+type instance Input RpcStorageGetRef = RefAlias2
 type instance Output RpcStorageGetRef = Maybe HashRef
 
-type instance Input RpcStorageUpdateRef = (RefAlias, HashRef)
+type instance Input RpcStorageUpdateRef = (RefAlias2, HashRef)
 type instance Output RpcStorageUpdateRef = ()
 
-type instance Input RpcStorageDelRef = RefAlias
+type instance Input RpcStorageDelRef = RefAlias2
 type instance Output RpcStorageDelRef = ()
 

hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs

@@ -8,7 +8,7 @@ module HBS2.Peer.RPC.Client.StorageClient
 import HBS2.Prelude.Plated
 
 import HBS2.Hash
-import HBS2.Data.Types.Refs (HashRef(..),refAlias)
+import HBS2.Data.Types.Refs (HashRef(..),refAlias,refMetaData)
 import HBS2.Net.Proto.Service
 import HBS2.Storage
 
@@ -56,6 +56,7 @@ instance ( MonadIO m
     void $ callService @RpcStorageDelBlock (fromStorageClient s) (HashRef h)
 
   updateRef s ref v = liftIO do
+    notice $ "metadata!" <+> pretty (refMetaData ref)
     void $ callService @RpcStorageUpdateRef (fromStorageClient s) (refAlias ref, HashRef v)
 
   getRef s ref = liftIO do

hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs

@@ -9,7 +9,7 @@ module HBS2.Peer.RPC.Internal.Storage
 
 import HBS2.Prelude.Plated
 import HBS2.Actors.Peer.Types
-import HBS2.Data.Types.Refs (HashRef(..))
+import HBS2.Data.Types.Refs (HashRef(..),refMetaData)
 import HBS2.Storage
 import HBS2.Peer.RPC.Class
 import HBS2.Peer.RPC.API.Storage
@@ -73,7 +73,7 @@ instance (StorageContext m) => HandleMethod m RpcStorageGetRef where
 instance (StorageContext m) => HandleMethod m RpcStorageUpdateRef where
 
   handleMethod (ref, val) = do
-    debug $ "rpc.storage.updateRef" <+> pretty ref
+    debug $ "rpc.storage.updateRef" <+> pretty ref <+> pretty (refMetaData ref)
     sto <- getStorage
     liftIO $ updateRef sto ref (fromHashRef val)
 

hbs2-storage-simple/benchmarks/Main.hs

@@ -1,7 +1,9 @@
+{-# Language TemplateHaskell #-}
 module Main where
 
 import HBS2.Prelude
 import HBS2.Hash
+import HBS2.Data.Types.Refs
 import HBS2.Storage
 import HBS2.Storage.Simple
 
@@ -17,13 +19,22 @@ import Control.Monad (replicateM)
 import Data.ByteString.Lazy  qualified as LBS
 import Data.Word (Word8)
 
+import Data.Function
 import Text.InterpolatedString.Perl6 (qc)
 import Control.Monad
 import UnliftIO
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+import Data.Map (Map)
+import Data.Map qualified as Map
 
 import Streaming.Prelude (Of,Stream)
 import Streaming.Prelude qualified as S
 
+import Control.Concurrent.STM (retry,flushTQueue)
+
+import Codec.Serialise
+
 -- Генерация одного случайного байта
 randomByte :: IO Word8
 randomByte = randomRIO (0, 255)
@@ -41,6 +52,9 @@ randomByteStrings n len = replicateM_ n $ do
     bs <- liftIO $ randomByteString len
     S.yield bs
 
+-- chunkStream :: Monad m => Int -> Stream (Of LBS.ByteString) m r -> Stream (Of [LBS.ByteString]) m r
+-- chunkStream n = S.mapsM (sequence . take n) . S.chunksOf n
+
 main :: IO ()
 main = do
   (ns:ss:pref:_) <- getArgs
@@ -49,8 +63,13 @@ main = do
   let s = readDef @Int 256 ss
   let p = pref
 
-  let bss = randomByteStrings n s
+  -- let bss = randomByteStrings n s
   let bss2 = randomByteStrings n s
+  let bss3 = randomByteStrings n s
+  -- let bss41 = randomByteStrings (n `div` 2) s
+  -- let bss42 = randomByteStrings (n`div` 2) s
+  -- let bss43 = randomByteStrings (n`div`4) s
+  -- let bss44 = randomByteStrings (n`div`4) s
 
   let path = pref </> ".test-storage"
 
@@ -72,8 +91,8 @@ main = do
 
   print $ "preparing to write" <+> pretty n <+> "chunks"
 
-  timeItNamed "write chunks test" do
+  -- timeItNamed "write chunks test" do
-    S.mapM_ (enqueueBlock storage) bss
+  --   S.mapM_ (enqueueBlock storage) bss
 
   timeItNamed "write chunks to sqlite test" do
     withDB env $ transactional do
@@ -81,3 +100,89 @@ main = do
         let h = hashObject @HbSync bs & pretty & show
         insert [qc|insert into wtf (hash,val) values(?,?)|] (h,bs)
 
+  timeItNamed "write chunks to log" do
+    fh <- openFile (path </> "lsm") AppendMode
+    flip S.mapM_  bss3 $ \bs -> do
+      let h = hashObject @HbSync bs & pretty & show
+      LBS.hPut fh (serialise (h,bs))
+    hClose fh
+
+  timeItNamed "write chunks to log 2" do
+    buf <- newIORef (mempty, 0 :: Int)
+    fh <- openFile (path </> "lsm2") AppendMode
+
+    flip S.mapM_  bss3 $ \bs -> do
+      let h = hashObject @HbSync bs & pretty & show
+      num <- atomicModifyIORef buf (\(chunks,sz) -> ((serialise (h,bs) : chunks,sz+1),sz+1))
+
+      when (num >= 16) do
+        w <- atomicModifyIORef buf (\(chunks,_) -> ((mempty,0),chunks))
+        LBS.hPut fh (mconcat w)
+
+    (w,_) <- readIORef buf
+    LBS.hPut fh (mconcat w)
+    hClose fh
+
+
+  timeItNamed "write chunks to LSM-mock" do
+
+    if n*s > 1073741824 then do
+      print "too much"
+    else do
+
+      let k = 6
+      let batch = 100
+
+      rem  <- newTVarIO n
+      quit <- newTVarIO False
+      out  <- newTQueueIO
+      queue <- newTQueueIO
+
+      w1 <- async do
+              fix \next -> do
+                r <- readTVarIO rem
+                when (r > 0) do
+                  b <- S.toList_ (randomByteStrings (min r batch) s)
+                  atomically $ do
+                    writeTQueue queue b
+                    modifyTVar rem (+ (-batch))
+                  next
+              atomically $ writeTVar quit True
+
+      as <- forM [1..k] \j -> async do
+              mem <- newIORef mempty
+              -- mem <- newTVarIO mempty
+              fix \next -> do
+
+                b <- atomically $ do
+                      q <- readTVar quit
+                      if q
+                        then return Nothing
+                        else (Just <$> readTQueue queue)
+                                 `orElse` (
+                                      readTVar quit >>= \z -> if z then pure Nothing else retry
+                                  )
+                case b of
+                  Nothing -> pure ()
+                  Just bss -> do
+
+                    new <- for bss $ \bs -> do
+                      let h = hashObject @HbSync bs & HashRef
+                      pure $ (h, bs)
+
+                    modifyIORef' mem (HashMap.union (HashMap.fromList new))
+                    -- atomically $ modifyTVar mem (Map.union (Map.fromList new))
+                    next
+
+              co <- readIORef mem
+              -- co <- readTVarIO mem
+              atomically $ writeTQueue out co
+
+      mapM_ wait (w1:as)
+
+      result <- atomically $ flushTQueue out
+      h <- openFile (path </> "lsm3") WriteMode
+      LBS.hPut h (serialise result)
+      hClose h
+
+

hbs2-storage-simple/hbs2-storage-simple.cabal

@@ -76,6 +76,8 @@ library
                     , stm
                     , stm-chans
                     , streaming
+                    , serialise
+                    , time
                     , transformers
                     , uniplate
                     , unordered-containers
@@ -136,7 +138,7 @@ executable hbs2-storage-simple-benchmarks
           -- -fno-warn-unused-binds
           -threaded
           -rtsopts
-          "-with-rtsopts=-N4 -A64m -AL256m -I0"
+          "-with-rtsopts=-N8 -A64m -AL256m -I0"
 
     main-is:          Main.hs
     -- other-modules:
@@ -172,6 +174,7 @@ executable hbs2-storage-simple-benchmarks
                     , stm
                     , unliftio
                     , network-byte-order
+                    , unordered-containers
 
     hs-source-dirs: benchmarks
     default-language: Haskell2010

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

@@ -10,6 +10,7 @@ module HBS2.Storage.Simple
 import HBS2.Clock
 import HBS2.Hash
 import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs (refMetaData)
 import HBS2.Storage
 import HBS2.Base58
 
@@ -27,6 +28,9 @@ import Data.ByteString (ByteString)
 import Data.Foldable
 import Data.List qualified as L
 import Data.Maybe
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Either
 import Lens.Micro.Platform
 import Prettyprinter
 import System.Directory
@@ -36,6 +40,7 @@ import System.IO.Error
 import System.IO.Temp
 import System.AtomicWrite.Writer.LazyByteString qualified as AwLBS
 import System.AtomicWrite.Writer.ByteString qualified as AwBS
+import Data.Time.Clock.POSIX (getPOSIXTime)
 
 import Data.HashMap.Strict qualified as HashMap
 import Data.HashMap.Strict (HashMap)
@@ -48,6 +53,7 @@ import Control.Concurrent.STM.TBMQueue qualified as TBMQ
 import Control.Concurrent.STM.TBMQueue (TBMQueue)
 import Control.Concurrent.STM.TVar qualified as TV
 
+import Codec.Serialise
 
 
 -- NOTE:  random accessing files in a git-like storage
@@ -350,17 +356,30 @@ simpleWriteLinkRawRef :: forall h . ( IsSimpleStorageKey h
                                  , ToByteString (AsBase58 (Hash h))
                                  )
                       => SimpleStorage h
+                      -> [(String, String)]
                       -> Hash h
                       -> Hash h
                       -> IO ()
 
-simpleWriteLinkRawRef ss h ref = do
+simpleWriteLinkRawRef ss meta h ref = do
   let fnr = simpleRefFileName ss h
   void $ spawnAndWait ss $ do
     AwBS.atomicWriteFile fnr (toByteString (AsBase58 ref))
       `catchAny` \_ -> do
         err $ "simpleWriteLinkRawRef" <+> pretty h <+> pretty ref <+> pretty fnr
 
+    unless (null meta) do
+      let metaname = fnr `addExtension` "metadata"
+      meta0 <- try @IOError (LBS.readFile metaname)
+                              <&> fromRight mempty
+                              <&> deserialiseOrFail @(Map String String)
+                              <&> fromRight mempty
+      let meta1 = meta0 <> Map.fromList meta
+      r <- try @IOError $ AwBS.atomicWriteFile metaname (LBS.toStrict $ serialise meta1)
+      case r of
+        Right{} -> pure ()
+        Left e  -> err $ "simpleWriteLinkRawRef" <+> viaShow e
+
 simpleReadLinkRaw :: forall r h . ( IsKey h, Hashed h r, Pretty r)
                   => SimpleStorage h
                   -> r
@@ -370,14 +389,43 @@ simpleReadLinkRaw ss ref = do
   let hash = hashObject @h ref
   let fn = simpleRefFileName ss hash
   rs <- spawnAndWait ss $ do
+          meta <- try @IOError (LBS.readFile (fn `addExtension` "metadata"))
+                     >>= \case
+                            Left{}    -> pure mempty
+                            Right sm  -> pure $ deserialiseOrFail @(Map String String) sm & fromRight mempty
+
+          deleted <- runMaybeT do
+            ts <- toMPlus $ Map.lookup "expires" meta
+            t0 <- toMPlus $ readMay @Int ts
+            now <- liftIO $ getPOSIXTime <&> round
+
+            if now <= t0 then do
+              pure False
+            else do
+              liftIO $ simpleDelRef ss hash
+              pure True
+
+          if deleted == Just True then do
+            pure Nothing
+          else do
             -- FIXME: log-this-situation
             (Just <$> LBS.readFile fn) `catchAny` \e -> do
+              -- TODO: update-stats-instead-of-spamming
               err $ "simpleReadLinkRaw" <+> pretty ref <+> pretty fn <+> viaShow e
               pure Nothing
 
   pure $ fromMaybe Nothing rs
 
 
+simpleDelRef :: IsKey h => SimpleStorage h -> Hash h -> IO ()
+simpleDelRef ss hash = do
+  let fn = simpleRefFileName ss hash
+  here <- doesFileExist fn
+  when here (removeFile fn)
+  let meta = fn `addExtension` "metadata"
+  mhere <- doesFileExist meta
+  when mhere (removeFile meta)
+
 simpleReadLinkVal :: ( IsKey h
                      , IsSimpleStorageKey h
                      , Hashed h LBS.ByteString
@@ -416,8 +464,9 @@ instance ( MonadIO m, IsKey hash
 
   updateRef ss ref v = do
     let refHash = hashObject @hash ref
+    let meta = refMetaData ref
     debug $ "updateRef:" <+> pretty refHash
-    void $ liftIO $ simpleWriteLinkRawRef ss refHash v
+    void $ liftIO $ simpleWriteLinkRawRef ss meta refHash v
 
   getRef ss ref = do
     runMaybeT do
@@ -435,8 +484,7 @@ instance ( MonadIO m, IsKey hash
 
   delRef ss ref = do
     let refHash = hashObject @hash ref
-    let fn = simpleRefFileName ss refHash
     void $ liftIO $ spawnAndWait ss $ do
-      here <- doesFileExist fn
+      simpleDelRef ss refHash
-      when here (removeFile fn)
+
 

hbs2/Main.hs

@@ -5,6 +5,7 @@ import HBS2.Data.Detect
 import HBS2.Data.Types
 import HBS2.Data.Types.EncryptedBox
 import HBS2.Data.Types.SignedBox
+import HBS2.Data.KeyRing as KeyRing
 import HBS2.Defaults
 import HBS2.Merkle
 import HBS2.Net.Proto.Types
@@ -380,7 +381,7 @@ runStore opts ss = runResourceT do
 
             let segments = readChunked fh (fromIntegral defBlockSize)
 
-            let source = ToEncryptSymmBS gks nonce segments gk NoMetaData Nothing
+            let source = ToEncryptSymmBS gks (Right gk) nonce segments  NoMetaData Nothing
 
             r <- runExceptT $ writeAsMerkle ss source
 
@@ -536,6 +537,7 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "fsck"            (info pFsck (progDesc "check storage constistency"))
                         <> command "deps"            (info pDeps (progDesc "print dependencies"))
                         <> command "del"             (info pDel (progDesc "del block"))
+                        <> command "keyring"         (info pKeyRing (progDesc "keyring commands"))
                         <> 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"))
@@ -674,6 +676,16 @@ main = join . customExecParser (prefs showHelpOnError) $
       f <- strArgument ( metavar "KEYRING-FILE" )
       pure (runKeyDel s f)
 
+    pKeyRing = hsubparser ( command "find" (info pKeyRingFind (progDesc "find keyring"))
+                          )
+
+    pKeyRingFind = do
+      spk <- option pPubKey ( long "sign-key" <> short 's' <> help "sign-key" )
+      masks <- many (strArgument (metavar "PATHS"))
+      pure do
+        krf <- KeyRing.findKeyRing masks spk
+        print $ vcat (fmap pretty krf)
+
     pReflog = hsubparser ( command "get" (info pRefLogGet (progDesc "get reflog root") )  )
 
     -- FIXME: only-for-hbs2-basic-encryption
@@ -872,6 +884,8 @@ main = join . customExecParser (prefs showHelpOnError) $
     phref = maybeReader fromStringMay
 
 
+    pPubKey = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic))
+