From f3a4082099a24c8c22b5215e753594289b813efb Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 1 Dec 2023 10:59:07 +0300 Subject: [PATCH] new encryption format --- hbs2-core/lib/HBS2/Merkle.hs | 26 ++++++- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 82 ++++++++++++--------- hbs2-git/lib/HBS2Git/App.hs | 2 +- hbs2-git/lib/HBS2Git/Import.hs | 4 +- hbs2-tests/test/playground/Main.hs | 22 ++++++ hbs2/Main.hs | 2 +- 6 files changed, 98 insertions(+), 40 deletions(-) diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index 05da1a4d..81bf55e3 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -1,5 +1,7 @@ {-# Language TemplateHaskell #-} {-# Language DeriveFunctor #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} module HBS2.Merkle where import HBS2.Prelude @@ -14,12 +16,15 @@ import Data.Data import Data.Foldable (forM_, traverse_) import Data.List qualified as List import Data.Text (Text) +import Data.Word import GHC.Generics import Lens.Micro.Platform import Control.Monad.Trans.Maybe import Control.Monad import Prettyprinter + + newtype MerkleHash = MerkleHash { fromMerkleHash :: Hash HbSync } deriving newtype (Eq,Ord,IsString,Pretty) deriving stock (Data,Generic) @@ -97,14 +102,33 @@ instance Serialise a => Serialise (MTreeAnn a) data MerkleEncryptionType deriving stock (Data) +data EncryptGroupNaClSymmOpts = + EncryptGroupNaClSymmBlockSIP (Word64, Word64) + deriving stock (Eq,Ord,Show,Generic,Data) + +instance Serialise EncryptGroupNaClSymmOpts + data MTreeEncryption = NullEncryption | CryptAccessKeyNaClAsymm (Hash HbSync) - | EncryptGroupNaClSymm (Hash HbSync) ByteString + | EncryptGroupNaClSymm1 (Hash HbSync) ByteString + | EncryptGroupNaClSymm2 EncryptGroupNaClSymmOpts (Hash HbSync) ByteString deriving stock (Eq,Generic,Data,Show) instance Serialise MTreeEncryption +pattern EncryptGroupNaClSymm :: Hash HbSync -> ByteString -> MTreeEncryption +pattern EncryptGroupNaClSymm a b <- ( isEncryptGroupNaClSymm -> Just (a, b) ) where + EncryptGroupNaClSymm a b = EncryptGroupNaClSymm1 a b + +isEncryptGroupNaClSymm :: MTreeEncryption + -> Maybe (Hash HbSync, ByteString) +isEncryptGroupNaClSymm = \case + EncryptGroupNaClSymm2 _ a b -> Just (a,b) + EncryptGroupNaClSymm1 a b -> Just (a,b) + _ -> Nothing + + data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a deriving stock (Generic,Data,Show) diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 3380cbbb..1140f9f2 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} {-# Language ConstraintKinds #-} @@ -23,6 +22,8 @@ import HBS2.Storage.Operations.ByteString import HBS2.Storage(Storage(..)) +import Data.ByteArray.Hash qualified as BA +import Data.ByteArray.Hash (SipHash(..), SipKey(..)) import Codec.Serialise import Crypto.KDF.HKDF qualified as HKDF import Control.Monad @@ -58,6 +59,7 @@ import Data.Bits (xor) type GroupSecretAsymm = Key + -- NOTE: breaking-change -- NOTE: not-a-monoid @@ -88,6 +90,7 @@ data instance ToEncrypt 'Symm s LBS.ByteString = , toEncryptData :: Stream (Of LBS.ByteString) IO () , toEncryptGroupKey :: GroupKey 'Symm s , toEncryptMeta :: AnnMetaData + , toEncryptOpts :: Maybe EncryptGroupNaClSymmOpts } deriving (Generic) @@ -219,33 +222,30 @@ instance ( MonadIO m let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust - -- NOTE: new-format-and-compatibility - -- мы можем: - -- 1. поменять схему и схему вычисления нонсов - -- сделать зависимой от схемы. Вот мы пишем - -- её внизу, это ок. - -- Минусы: сложнее код, менее локальный - -- Плюсы: надёжнее - -- Совместимость: обратная? старая версия - -- не будет читать новые блоки. - -- - -- 2. сериализовать блок с параметрами - -- при чтении: пытаемся десереализовать, - -- как блок (читать голову). если не удаётся - -- --- читаем, как байтстроку. - -- минусы: будет медленнее --- лишняя проверка/попытка - -- десереализации на каждый блок. - -- плюсы: более локальные изменения - -- + let method = case toEncryptOpts source of + Nothing -> + EncryptGroupNaClSymm1 (fromHashRef gkh) nonceS + + Just o@(EncryptGroupNaClSymmBlockSIP{}) -> + EncryptGroupNaClSymm2 o (fromHashRef gkh) nonceS + + let onBlock (i,bs) = do + case toEncryptOpts source of + Just (EncryptGroupNaClSymmBlockSIP (a,b)) -> do + let bss = LBS.toStrict bs + let (SipHash sip) = BA.sipHash (SipKey a b) bss + let nonceI = nonceFrom (nonce0, i + sip) + let encrypted = SK.secretbox key0 nonceI bss + pure $ serialise (nonceI, encrypted) + + _ -> do + let nonceI = nonceFrom (nonce0, i) + let encrypted = SK.secretbox key0 nonceI (LBS.toStrict bs) + pure (LBS.fromStrict encrypted) hashes' <- liftIO $ toEncryptData source & S.zip (S.enumFrom (1 :: Word64) ) - & S.mapM ( \(i,bs) -> do - let nonceI = nonceFrom (nonce0, i) - let encrypted = SK.secretbox key0 nonceI (LBS.toStrict bs) - pure (LBS.fromStrict encrypted) - ) - + & S.mapM onBlock & S.mapM (enqueueBlock sto) & S.map (fmap HashRef) & S.toList_ @@ -264,11 +264,13 @@ instance ( MonadIO m tree <- maybe (throwError StorageError) pure root - let ann = MTreeAnn (toEncryptMeta source) (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree + let ann = MTreeAnn (toEncryptMeta source) method tree putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure +data EncMethod = Method1 | Method2 + instance ( MonadIO m , MonadError OperationError m , h ~ HbSync @@ -279,7 +281,7 @@ instance ( MonadIO m data instance TreeKey (ToDecrypt 'Symm sch ByteString) = ToDecryptBS [KeyringEntry sch] (Hash HbSync) - | ToDecryptBS2 (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTree [HashRef]) + | ToDecryptBS2 (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTreeAnn [HashRef]) type instance ToBlockR (ToDecrypt 'Symm sch ByteString) = ByteString type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString @@ -297,23 +299,33 @@ instance ( MonadIO m let nonce0 = nonceFrom @SK.Nonce nonceS hashes <- S.toList_ $ - walkMerkleTree tree (lift . getBlock sto) $ \case + walkMerkleTree (_mtaTree tree) (lift . getBlock sto) $ \case Left{} -> throwError MissedBlockError Right hrr -> S.each hrr + + method <- case _mtaCrypt tree of + EncryptGroupNaClSymm1{} -> pure Method1 + EncryptGroupNaClSymm2 (EncryptGroupNaClSymmBlockSIP _) _ _ -> pure Method2 + _ -> throwError UnsupportedFormat + ss <- forM (zip [1..] hashes) $ \(i :: Word64,h) -> do blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure - let nonceI = nonceFrom (nonce0, i) - - let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk) - - maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) + case method of + Method1 -> do + let nonceI = nonceFrom (nonce0, i) + let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk) + maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) + Method2 -> do + (nonce, bss) <- deserialiseOrFail @(SK.Nonce, N.ByteString) blk + & either (const $ throwError UnsupportedFormat) pure + let unboxed = SK.secretboxOpen key0 nonce bss + maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) -- FIXME: stream-unboxed-blocks pure $ mconcat ss - where decryptDataFrom = \case @@ -328,7 +340,7 @@ instance ( MonadIO m let what = tryDetect h bs let tree' = case what of - MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n)) + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (ann, (g,n)) _ -> Nothing (tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 86f105e8..0b3de89c 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -453,7 +453,7 @@ storeObjectRPC True repo meta bs = do & LBS.toStrict let bsStream = readChunkedBS bs defBlockSize - let source = ToEncryptSymmBS gks nonce bsStream gk0 (ShortMetadata txt) + let source = ToEncryptSymmBS gks nonce bsStream gk0 (ShortMetadata txt) Nothing h <- runExceptT (writeAsMerkle sto source) >>= either (const cantWriteMerkle) pure diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index e27c8cc6..5623c0f9 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -257,7 +257,7 @@ importRefLogNew opts ref = runResourceT do (src, enc) <- case something of - MerkleAnn (MTreeAnn _ sc@(EncryptGroupNaClSymm g nonce) tree) -> do + MerkleAnn ann@(MTreeAnn _ sc@(EncryptGroupNaClSymm g nonce) tree) -> do gk10' <- runExceptT $ readFromMerkle sto (SimpleKey g) @@ -271,7 +271,7 @@ importRefLogNew opts ref = runResourceT do let gk1 = mconcat $ gk10 : gk11 -- elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS decrypt (fromHashRef h)) - elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS2 gk1 nonce decrypt tree) + elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS2 gk1 nonce decrypt ann) case elbs of Left{} -> do diff --git a/hbs2-tests/test/playground/Main.hs b/hbs2-tests/test/playground/Main.hs index 32b37fd5..284e3f91 100644 --- a/hbs2-tests/test/playground/Main.hs +++ b/hbs2-tests/test/playground/Main.hs @@ -1,4 +1,5 @@ {-# Language RecordWildCards #-} +{-# Language PatternSynonyms, ViewPatterns #-} module Main where import HBS2.Prelude @@ -43,6 +44,27 @@ a1Str = lens g s -- новая версия: должна понимать и старую, и новую голову. -- + +data W = A | B0 | B1 Bool + +isB a = case a of + B0 -> True + B1 _ -> True + _ -> False + +-- -- Определяем паттерн-синоним для B, который будет сопоставлять B0 и B1 +pattern B :: Bool -> W +pattern B b <- (isB -> b) + +{-# COMPLETE A, B #-} + +-- -- Функция test использует паттерн B для сопоставления с образцом +test :: W -> String +test w = case w of + B val -> "Match B with value " ++ show val + A -> "Match A" + + main :: IO () main = do print "1" diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 79e47290..b0b0363f 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -380,7 +380,7 @@ runStore opts ss = runResourceT do let segments = readChunked fh (fromIntegral defBlockSize) - let source = ToEncryptSymmBS gks nonce segments gk NoMetaData + let source = ToEncryptSymmBS gks nonce segments gk NoMetaData Nothing r <- runExceptT $ writeAsMerkle ss source