voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

new encryption format

This commit is contained in:
Dmitry Zuikov 2023-12-01 10:59:07 +03:00
parent be55aa55e7
commit f3a4082099
6 changed files with 98 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
hbs2-core/lib/HBS2/Merkle.hs
View File

@ -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)

72
hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs
View File

@ -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
hashes' <- liftIO $ toEncryptData source
& S.zip (S.enumFrom (1 :: Word64) )
& S.mapM ( \(i,bs) -> do
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 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
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

2
hbs2-git/lib/HBS2Git/App.hs
View File

@ -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

4
hbs2-git/lib/HBS2Git/Import.hs
View File

@ -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

22
hbs2-tests/test/playground/Main.hs
View File

@ -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"

2
hbs2/Main.hs
View File

@ -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