symm-group-encryption, schema changed

Accordingly to vulnerabilities review made by rblaze

hbs2-core/lib/HBS2/Merkle.hs

@@ -97,7 +97,7 @@ data MerkleEncryptionType
 data MTreeEncryption
   = NullEncryption
   | CryptAccessKeyNaClAsymm (Hash HbSync)
-  | EncryptGroupNaClSymm (Hash HbSync)
+  | EncryptGroupNaClSymm (Hash HbSync) ByteString
   deriving stock (Eq,Generic,Data,Show)
 
 instance Serialise MTreeEncryption

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -70,6 +70,7 @@ instance Serialise SK.Nonce
 data instance ToEncrypt 'Symm s LBS.ByteString =
   ToEncryptSymmBS
   { toEncryptSecret      :: GroupSecretAsymm
+  , toEncryptNonce       :: BS.ByteString
   , toEncryptData        :: Stream (Of LBS.ByteString) IO ()
   , toEncryptGroupKey    :: GroupKey 'Symm s
   }
@@ -143,8 +144,8 @@ lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
   MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
 
 -- FIXME: move-to-appropriate-place
-class NonceFrom a nonce where
+class NonceFrom nonce a where
-  nonceFrom :: nonce -> a -> nonce
+  nonceFrom :: a -> nonce
 
 typicalNonceLength :: Integral a => a
 typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length & fromIntegral
@@ -152,9 +153,9 @@ typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length &
 typicalKeyLength :: Integral a => a
 typicalKeyLength = unsafePerformIO SK.newKey & Saltine.encode & B8.length & fromIntegral
 
-instance NonceFrom Word64 SK.Nonce where
+instance NonceFrom SK.Nonce (SK.Nonce, Word64) where
   -- FIXME: maybe-slow-nonceFrom
-  nonceFrom n0 w = fromJust $ Saltine.decode nss
+  nonceFrom (n0, w) = fromJust $ Saltine.decode nss
     where
       ws = noncePrefix <> N.bytestring64 w
       ns = Saltine.encode n0
@@ -162,6 +163,20 @@ instance NonceFrom Word64 SK.Nonce where
 
       noncePrefix = BS.replicate (typicalNonceLength - 8) 0
 
+instance NonceFrom SK.Nonce ByteString where
+  -- FIXME: maybe-slow-nonceFrom
+  nonceFrom lbs = fromJust $ Saltine.decode
+                           $ LBS.toStrict
+                           $ LBS.take typicalNonceLength
+                           $ lbs <> LBS.replicate typicalNonceLength 0
+
+
+instance NonceFrom SK.Nonce BS.ByteString where
+  -- FIXME: maybe-slow-nonceFrom
+  nonceFrom bs = fromJust $ Saltine.decode
+                          $ BS.take typicalNonceLength
+                          $ bs <> BS.replicate typicalNonceLength 0
+
 -- Раз уж такое, то будем писать метаинформацию
 -- В блок #0,
 -- А HashRef#1 - будет ссылка на групповой ключ
@@ -191,20 +206,22 @@ instance ( MonadIO m
 
     let key = toEncryptSecret source
 
+    let nonceS = toEncryptNonce source
+
+    let nonce0 = nonceFrom @SK.Nonce (toEncryptNonce source)
+
     gkh <- writeAsMerkle sto (serialise gk) <&> HashRef
 
     let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode key)
 
-    hashes' <- liftIO $ toEncryptData source
+    let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
 
-                & S.mapM ( \bs -> do
+    hashes' <- liftIO $ toEncryptData source
-                             let (BA.SipHash w64) = BA.sipHash (BA.SipKey 11940070621075034887 442907749530188102) (LBS.toStrict bs)
+                & S.zip (S.enumFrom (1 :: Word64) )
-                             let hbs = N.bytestring64 w64
+                & S.mapM ( \(i,bs) -> do
-                             let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust
+                             let nonceI = nonceFrom (nonce0, i)
-                             let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0)
+                             let encrypted = SK.secretbox key0 nonceI (LBS.toStrict bs)
-                             let nonce = Saltine.decode nonceS & fromJust
+                             pure (LBS.fromStrict encrypted)
-                             let encrypted = SK.secretbox key0 nonce (LBS.toStrict bs)
-                             pure $ serialise (hbs, encrypted)
                          )
 
                 & S.mapM (enqueueBlock sto)
@@ -217,15 +234,15 @@ instance ( MonadIO m
     let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings
 
     -- FIXME: this-might-not-be-true
-    result <- runWriterT $ makeMerkle 0 pt $ \(_,mt,bss) -> do
+    result <- runWriterT $ makeMerkle 0 pt $ \(hx,mt,bss) -> do
       void $ lift $ putBlock sto bss
-      tell [mt]
+      tell $ [(hx,mt)]
 
-    let root = headMay (snd result)
+    let root = headMay [ mt | (h,mt) <- snd result, h == fst result ]
 
     tree <- maybe (throwError StorageError) pure root
 
-    let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh)) tree
+    let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree
 
     putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure
 
@@ -251,10 +268,10 @@ instance ( MonadIO m
     let what = tryDetect h bs
 
     let tree' = case what of
-          MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g}) -> Just (_mtaTree ann, g)
+          MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n))
           _ -> Nothing
 
-    (tree, gkh) <- maybe1 tree' (throwError UnsupportedFormat) pure
+    (tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure
 
     gkbs <- readFromMerkle sto (SimpleKey gkh)
 
@@ -265,28 +282,23 @@ instance ( MonadIO m
     gksec <- maybe1 gksec' (throwError GroupKeyNotFound) pure
 
     let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec)
+    let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
+    let nonce0 = nonceFrom @SK.Nonce nonceS
 
     hashes <- S.toList_ $
       walkMerkleTree tree (lift . getBlock sto) $ \case
         Left{} -> throwError MissedBlockError
         Right hrr -> S.each hrr
 
-    ss <- forM hashes $ \h -> do
+    ss <- forM (zip [1..] hashes) $ \(i :: Word64,h) -> do
       blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure
 
-      (hbs, bss) <- either (const $ throwError UnsupportedFormat)
+      let nonceI = nonceFrom (nonce0, i)
-                          pure
+      let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk)
-                          (deserialiseOrFail @(BS.ByteString, BS.ByteString) blk)
-
-
-      let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0)
-      let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust
-      let nonce = Saltine.decode nonceS & fromJust
-      let unboxed = SK.secretboxOpen key0 nonce bss
 
       maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
 
+    -- FIXME: stream-unboxed-blocks
     pure $ mconcat ss
 
 
-

hbs2-peer/app/BlockDownload.hs

@@ -159,7 +159,7 @@ processBlock h = do
        case _mtaCrypt ann of
           NullEncryption -> pure ()
           CryptAccessKeyNaClAsymm h -> addDownload parent h
-          EncryptGroupNaClSymm h    -> addDownload parent h
+          EncryptGroupNaClSymm h _  -> addDownload parent h
 
        debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h
        walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr

hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs

@@ -33,8 +33,8 @@ pieces :: Integral a => a
 pieces = 1024
 
 -- FIXME: to-remove-in-a-sake-of-operations-class
-class SimpleStorageExtra a  where
+class MonadIO m => SimpleStorageExtra a m  where
-  putAsMerkle :: forall h . (IsSimpleStorageKey h, Hashed h ByteString) => SimpleStorage h -> a -> IO MerkleHash
+  putAsMerkle :: forall h . (IsSimpleStorageKey h, Hashed h ByteString) => SimpleStorage h -> a -> m MerkleHash
 
 -- TODO: move-to-hbs2-storage-operations
 readChunked :: MonadIO m => Handle -> Int -> S.Stream (S.Of ByteString) m ()
@@ -65,7 +65,7 @@ readChunked handle size = fuu
 --  интересно, что при этом особо ничего не поменяется ---
 --  то есть система будет продолжать работать.
 
-instance SimpleStorageExtra Handle where
+instance MonadIO m => SimpleStorageExtra Handle m where
   putAsMerkle ss handle = do
 
     hashes <- readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
@@ -75,7 +75,7 @@ instance SimpleStorageExtra Handle where
 
     putAsMerkle ss hashes
 
-instance SimpleStorageExtra (S.Stream (S.Of ByteString) IO ()) where
+instance MonadIO m => SimpleStorageExtra (S.Stream (S.Of ByteString) m ()) m where
   putAsMerkle ss streamChunks = do
 
     hashes <- streamChunks
@@ -85,7 +85,7 @@ instance SimpleStorageExtra (S.Stream (S.Of ByteString) IO ()) where
 
     putAsMerkle ss hashes
 
-instance SimpleStorageExtra [HashRef] where
+instance MonadIO m => SimpleStorageExtra [HashRef] m where
   putAsMerkle ss hashes = do
 
     let pt = toPTree (MaxSize pieces) (MaxNum pieces) hashes -- FIXME: settings
@@ -94,7 +94,7 @@ instance SimpleStorageExtra [HashRef] where
 
     pure (MerkleHash root)
 
-instance SimpleStorageExtra ByteString where
+instance MonadIO m => SimpleStorageExtra ByteString m where
   putAsMerkle ss bs = do
 
     hashes <- S.each (B.unpack bs)

hbs2/Main.hs

@@ -28,35 +28,34 @@ import HBS2.System.Logger.Simple hiding (info)
 import Data.Config.Suckless
 import Data.Config.Suckless.KeyValue
 
-import Control.Concurrent.Async
+import Codec.Serialise
-import Control.Concurrent.STM
+import Control.Concurrent.STM qualified as STM
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Resource
 import Crypto.Saltine.Core.Box qualified as Encrypt
-import Data.ByteString.Lazy qualified as LBS
-import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Data.Either
 import Data.Function
 import Data.Functor
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Data.Monoid qualified as Monoid
-import Options.Applicative
-import System.Directory
-import Data.Either
 import Data.Maybe
+import Data.Monoid qualified as Monoid
 import Data.Text qualified as Text
 import Lens.Micro.Platform
--- import System.FilePath.Posix
+import Options.Applicative
-import System.IO
-import System.Exit
-
-import Codec.Serialise
-
 import Streaming.Prelude qualified as S
--- import Streaming qualified as S
+import Streaming.ByteString qualified as SB
+import System.Directory
+import System.Exit qualified as Exit
+import System.IO qualified as IO
+import System.IO.Temp (emptySystemTempFile)
+import UnliftIO
 
 
 tracePrefix :: SetLoggerEntry
@@ -142,6 +141,30 @@ newtype NewRefOpts =
 data EncSchema  = EncSymm   (GroupKey 'Symm HBS2Basic)
                 | EncAsymm  (GroupKey 'Asymm HBS2Basic)
 
+
+hPrint :: (MonadIO m, Show a) => Handle -> a -> m ()
+hPrint h s = liftIO $ IO.hPrint h s
+
+hGetContents :: MonadIO m => Handle -> m String
+hGetContents h = liftIO $ IO.hGetContents h
+
+hPutStrLn :: MonadIO m => Handle -> String -> m ()
+hPutStrLn h s = liftIO $ IO.hPutStrLn h s
+
+hPutStr :: MonadIO m => Handle -> String -> m ()
+hPutStr h s = liftIO $ IO.hPutStr h s
+
+exitSuccess :: MonadIO m => m ()
+exitSuccess = do
+  liftIO Exit.exitSuccess
+
+exitFailure :: MonadIO m => m ()
+exitFailure = do
+  liftIO Exit.exitFailure
+
+die :: MonadIO m => String -> m a
+die = liftIO . Exit.die
+
 runHash :: HashOpts -> SimpleStorage HbSync -> IO ()
 runHash opts _ = do
   withBinaryFile (hashFp opts) ReadMode $ \h -> do
@@ -282,16 +305,27 @@ runStore opts _ | justInit = do
   where
     justInit = maybe False fromOptInit (uniLastMay @OptInit opts)
 
-runStore opts ss = do
+runStore opts ss = runResourceT do
 
   let fname = uniLastMay @OptInputFile opts
   let meta58  = storeBase58Meta opts
 
-  handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
+  inputFile <- case fname of
+    Just (OptInputFile fn) -> pure fn
+
+    Nothing -> do
+      (_, fn) <- allocate (liftIO $ emptySystemTempFile "hbs2-store")
+                          (liftIO . removeFile)
+
+      SB.writeFile fn (SB.fromHandle stdin)
+      debug $ "It worked out!" <+> pretty fn
+      pure fn
+
+  maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
 
   case uniLastMay @OptGroupkeyFile opts of
-    Nothing -> do
+    Nothing -> liftIO $ IO.withFile inputFile IO.ReadMode $ \ha -> do
-        root' <- putAsMerkle ss handle
+        root' <- liftIO $ putAsMerkle ss ha
 
         root <- case meta58 of
                   Nothing -> pure root'
@@ -304,12 +338,12 @@ runStore opts ss = do
                                             MTreeAnn (ShortMetadata metad) NullEncryption  mtree
                     pure (MerkleHash mannh)
 
-        print $ "merkle-root: " <+> pretty root
+        hPrint stdout $ pretty root
 
     Just gkfile -> do
 
-      gkSymm  <- Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile)
+      gkSymm  <- liftIO $ Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile)
-      gkAsymm <- Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)
+      gkAsymm <- liftIO $ Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)
 
       let mbGk = EncSymm <$> gkSymm <|> EncAsymm <$> gkAsymm
 
@@ -320,7 +354,7 @@ runStore opts ss = do
           pk  <- unOptEncPk <$> pure (uniLastMay @OptEncPubKey opts) `orDie` "public key not specified"
           krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set"
 
-          s <- BS.readFile (unOptKeyringFile krf)
+          s <- liftIO $ BS.readFile (unOptKeyringFile krf)
           cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
 
           sk <- pure (headMay [ (view krPk k, view krSk k)
@@ -330,27 +364,30 @@ runStore opts ss = do
 
           gks <- pure (Symm.lookupGroupKey (snd sk) pk gk) `orDie` ("can't find secret key for " <> show (pretty (AsBase58 (fst sk))))
 
-          let  segments :: S.Stream (S.Of ByteString) IO ()
+          HbSyncHash nonce <- liftIO $ LBS.readFile inputFile <&> hashObject @HbSync
-               segments = readChunked handle (fromIntegral defBlockSize)
 
-          let source = ToEncryptSymmBS gks segments gk
+          debug $ "NONCE FUCKING CALCULATED:" <+> pretty (AsBase58 nonce)
+
+          fh <- liftIO $ IO.openFile inputFile IO.ReadMode
+
+          let segments = readChunked fh (fromIntegral defBlockSize)
+
+          let source = ToEncryptSymmBS gks nonce segments gk
 
           r <- runExceptT $ writeAsMerkle ss source
 
           case r of
             Left e  -> die (show e)
-            Right h -> print (pretty h)
+            Right h -> hPrint stdout (pretty h)
 
-        Just (EncAsymm gk) -> do
+        Just (EncAsymm gk) -> liftIO $ IO.withFile inputFile IO.ReadMode $ \ha -> do
 
           accKeyh <- (putBlock ss . serialise . permitted . accessKey) gk
               `orDie` "can not store access key"
 
-          let rawChunks :: S.Stream (S.Of ByteString) IO ()
+          let rawChunks = readChunked ha (fromIntegral defBlockSize) -- FIXME: to settings!
-              rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
 
-              encryptedChunks :: S.Stream (S.Of ByteString) IO ()
+          let encryptedChunks = rawChunks
-              encryptedChunks = rawChunks
                   & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict)
 
           mhash <- putAsMerkle ss encryptedChunks
@@ -361,7 +398,7 @@ runStore opts ss = do
                 =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do
               MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree
 
-          print $ "merkle-ann-root: " <+> pretty mannh
+          hPrint stdout $ "merkle-ann-root: " <+> pretty mannh
 
 runNewGroupKeyAsymm :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
 runNewGroupKeyAsymm pubkeysFile = do
@@ -658,7 +695,7 @@ main = join . customExecParser (prefs showHelpOnError) $
           deepScan ScanDeep (const none) h (getBlock sto) $ \ha -> do
             liftIO $ atomically $ writeTQueue q ha
 
-        deps <- liftIO $ atomically $ flushTQueue q
+        deps <- liftIO $ atomically $ STM.flushTQueue q
 
         forM_ deps $ \d -> do
           doDelete <- if dontAsk then do

hbs2/hbs2.cabal

@@ -86,13 +86,17 @@ executable hbs2
                     , saltine
                     , serialise
                     , streaming
+                    , streaming-bytestring
                     , suckless-conf
+                    , resourcet
                     , text
+                    , temporary
                     , transformers
                     , uniplate
                     , uuid
                     , terminal-progress-bar
                     , stm
+                    , unliftio
 
     hs-source-dirs:   .
     default-language: Haskell2010