mirror of https://github.com/voidlizard/hbs2
symm-group-encryption, schema changed
Accordingly to vulnerabilities review made by rblaze
This commit is contained in:
Dmitry Zuikov
parent
7572b3ffe9
commit
a3a5cf8f7f
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
105
hbs2/Main.hs
105
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue