mirror of https://github.com/voidlizard/hbs2
small-encrypted-block wip
This commit is contained in:
Dmitry Zuikov
parent
8bc92062bd
commit
f0d469766e
|
|
@ -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. Тогда при чтении (?) или время от временени:
|
||||
|
||||
читаем метаданные, смотрим, если ссылка протухла
|
||||
--- то удаляем её.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
refAlias x = RefAlias (HashRef $ hashObject @HbSync x)
|
||||
data RefAlias2 =
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Lens.Micro.Platform
|
||||
import Data.Maybe
|
||||
import System.Exit
|
||||
import HBS2.System.Logger.Simple hiding (info)
|
||||
import HBS2.System.Logger.Simple qualified as Log
|
||||
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Reader
|
||||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 = ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
S.mapM_ (enqueueBlock storage) bss
|
||||
-- timeItNamed "write chunks test" do
|
||||
-- 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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-- FIXME: log-this-situation
|
||||
(Just <$> LBS.readFile fn) `catchAny` \e -> do
|
||||
err $ "simpleReadLinkRaw" <+> pretty ref <+> pretty fn <+> viaShow e
|
||||
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
|
||||
when here (removeFile fn)
|
||||
simpleDelRef ss refHash
|
||||
|
||||
|
||||
|
|
|
|||
16
hbs2/Main.hs
16
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))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue