new encryption format

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)
 

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
+    let method = case toEncryptOpts source of
-    --  мы можем:
+          Nothing ->
-    --    1. поменять схему и схему вычисления нонсов
+            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
-    --    2. сериализовать блок с параметрами
+              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
+                & S.mapM onBlock
-                             let nonceI = nonceFrom (nonce0, i)
-                             let encrypted = SK.secretbox key0 nonceI (LBS.toStrict bs)
-                             pure (LBS.fromStrict encrypted)
-                         )
-
                 & 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)
+      case method of
-
+        Method1 -> do
-      let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk)
+          let nonceI = nonceFrom (nonce0, i)
-
+          let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk)
-      maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
+          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

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
 

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

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"

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