diff --git a/docs/todo/hbs2-storage-weak-refs.txt b/docs/todo/hbs2-storage-weak-refs.txt new file mode 100644 index 00000000..0416e366 --- /dev/null +++ b/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. Тогда при чтении (?) или время от временени: + + читаем метаданные, смотрим, если ссылка протухла + --- то удаляем её. + + + + + diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index ba329c75..1ee888b7 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Data/Types.hs b/hbs2-core/lib/HBS2/Data/Types.hs index bab8c8e4..5bcf4798 100644 --- a/hbs2-core/lib/HBS2/Data/Types.hs +++ b/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 + diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 60a902f0..1b4b564f 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/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 -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 diff --git a/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs b/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs new file mode 100644 index 00000000..7fbba673 --- /dev/null +++ b/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) + diff --git a/hbs2-core/lib/HBS2/Hash.hs b/hbs2-core/lib/HBS2/Hash.hs index 24dd4e5a..7b43310b 100644 --- a/hbs2-core/lib/HBS2/Hash.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index aaef42e3..06e43e2b 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 1140f9f2..67982ba4 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/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 + diff --git a/hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs b/hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs index 82f8397c..5c97cbe4 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index 4c07fdb3..a848e2ac 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index 5e1feb70..b9f2de20 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 8fd3beb6..94a21ee3 100644 --- a/hbs2-core/lib/HBS2/OrDie.hs +++ b/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)) + + diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 16f39852..73ba1011 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs index 95d0a378..a42554a0 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 0b3de89c..41373e4e 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/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 diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index eb13ccb0..bc451b76 100644 --- a/hbs2-peer/app/Brains.hs +++ b/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 diff --git a/hbs2-peer/app/CLI/Common.hs b/hbs2-peer/app/CLI/Common.hs index bfa92c06..5975eb81 100644 --- a/hbs2-peer/app/CLI/Common.hs +++ b/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 + diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index 93466f73..e79c115d 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/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 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) + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 6e43d248..9522158d 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs index 000d3c6a..81b64268 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs +++ b/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 = () diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs index b2863ded..6453da07 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs index 9aca0762..f4589282 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs +++ b/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) diff --git a/hbs2-storage-simple/benchmarks/Main.hs b/hbs2-storage-simple/benchmarks/Main.hs index f04913fb..6b635c41 100644 --- a/hbs2-storage-simple/benchmarks/Main.hs +++ b/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 - 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 + + diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index b98ea506..c331fb2b 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 1df09672..fb350229 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/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 - -- 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 + diff --git a/hbs2/Main.hs b/hbs2/Main.hs index b0b0363f..5573cc9d 100644 --- a/hbs2/Main.hs +++ b/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)) +