From a3a5cf8f7f3aa82723e7d6b50bd8f3c659f83ff4 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 27 Sep 2023 09:12:15 +0300 Subject: [PATCH] symm-group-encryption, schema changed Accordingly to vulnerabilities review made by rblaze --- hbs2-core/lib/HBS2/Merkle.hs | 2 +- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 72 +++++++----- hbs2-peer/app/BlockDownload.hs | 2 +- .../lib/HBS2/Storage/Simple/Extra.hs | 12 +- hbs2/Main.hs | 105 ++++++++++++------ hbs2/hbs2.cabal | 4 + 6 files changed, 125 insertions(+), 72 deletions(-) diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index 9330bb29..41bc32c3 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index d5bead92..c7d5f013 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/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 - nonceFrom :: nonce -> a -> nonce +class NonceFrom nonce a where + 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 - let (BA.SipHash w64) = BA.sipHash (BA.SipKey 11940070621075034887 442907749530188102) (LBS.toStrict bs) - let hbs = N.bytestring64 w64 - let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust - let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0) - let nonce = Saltine.decode nonceS & fromJust - let encrypted = SK.secretbox key0 nonce (LBS.toStrict bs) - pure $ serialise (hbs, 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 (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) - pure - (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 + let nonceI = nonceFrom (nonce0, i) + let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk) maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict) + -- FIXME: stream-unboxed-blocks pure $ mconcat ss - diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index 442188ae..f996d3a8 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs index 36e5aa9a..9f7a3b0b 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs +++ b/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 - putAsMerkle :: forall h . (IsSimpleStorageKey h, Hashed h ByteString) => SimpleStorage h -> a -> IO MerkleHash +class MonadIO m => SimpleStorageExtra a m where + 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) diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 9c0e5627..04653b1f 100644 --- a/hbs2/Main.hs +++ b/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 Control.Concurrent.STM +import Codec.Serialise +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 System.IO -import System.Exit - -import Codec.Serialise - +import Options.Applicative 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 - root' <- putAsMerkle ss handle + Nothing -> liftIO $ IO.withFile inputFile IO.ReadMode $ \ha -> do + 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) - gkAsymm <- Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile) + gkSymm <- liftIO $ Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.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 () - segments = readChunked handle (fromIntegral defBlockSize) + HbSyncHash nonce <- liftIO $ LBS.readFile inputFile <&> hashObject @HbSync - 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 () - rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings! + let rawChunks = readChunked ha (fromIntegral defBlockSize) -- FIXME: to settings! - encryptedChunks :: S.Stream (S.Of ByteString) IO () - encryptedChunks = rawChunks + let 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 diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 3ec649ec..f0b7f4a1 100644 --- a/hbs2/hbs2.cabal +++ b/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