diff --git a/package.yaml b/package.yaml index 9af86a4ca..735edf3fd 100644 --- a/package.yaml +++ b/package.yaml @@ -112,7 +112,7 @@ executables: - -threaded tests: - smp-server-test: + simplexmq-test: source-dirs: tests main: Test.hs dependencies: diff --git a/simplexmq.cabal b/simplexmq.cabal index fb6e1728e..eb106eaf9 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -63,6 +63,7 @@ library Simplex.Messaging.Client Simplex.Messaging.Client.Agent Simplex.Messaging.Crypto + Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet Simplex.Messaging.Encoding Simplex.Messaging.Encoding.String @@ -347,7 +348,7 @@ executable smp-server if flag(swift) cpp-options: -DswiftJSON -test-suite smp-server-test +test-suite simplexmq-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index a7ddf63cb..e536ba035 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -103,6 +103,7 @@ module Simplex.Messaging.Crypto -- * NaCl crypto_box CbNonce (unCbNonce), + pattern CbNonce, cbEncrypt, cbEncryptMaxLenBS, cbDecrypt, @@ -112,6 +113,7 @@ module Simplex.Messaging.Crypto -- * NaCl crypto_secretbox SbKey (unSbKey), + pattern SbKey, sbEncrypt, sbDecrypt, sbKey, @@ -698,6 +700,8 @@ data CryptoError AESDecryptError | -- CryptoBox decryption error CBDecryptError + | -- Poly1305 initialization error + CryptoPoly1305Error CE.CryptoError | -- | message is larger that allowed padded length minus 2 (to prepend message length) -- (or required un-padded length is larger than the message length) CryptoLargeMsgError @@ -961,9 +965,14 @@ sbDecrypt_ secret (CbNonce nonce) packet (rs, msg) = xSalsa20 secret nonce c tag = Poly1305.auth rs c -newtype CbNonce = CbNonce {unCbNonce :: ByteString} +newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString} deriving (Eq, Show) +pattern CbNonce :: ByteString -> CbNonce +pattern CbNonce s <- CryptoBoxNonce s + +{-# COMPLETE CbNonce #-} + instance StrEncoding CbNonce where strEncode (CbNonce s) = strEncode s strP = cbNonce <$> strP @@ -974,24 +983,33 @@ instance ToJSON CbNonce where cbNonce :: ByteString -> CbNonce cbNonce s - | len == 24 = CbNonce s - | len > 24 = CbNonce . fst $ B.splitAt 24 s - | otherwise = CbNonce $ s <> B.replicate (24 - len) (toEnum 0) + | len == 24 = CryptoBoxNonce s + | len > 24 = CryptoBoxNonce . fst $ B.splitAt 24 s + | otherwise = CryptoBoxNonce $ s <> B.replicate (24 - len) (toEnum 0) where len = B.length s randomCbNonce :: IO CbNonce -randomCbNonce = CbNonce <$> getRandomBytes 24 +randomCbNonce = CryptoBoxNonce <$> getRandomBytes 24 pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce -pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar +pseudoRandomCbNonce gVar = CryptoBoxNonce <$> pseudoRandomBytes 24 gVar pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString pseudoRandomBytes n gVar = stateTVar gVar $ randomBytesGenerate n -newtype SbKey = SbKey {unSbKey :: ByteString} +instance Encoding CbNonce where + smpEncode = unCbNonce + smpP = CryptoBoxNonce <$> A.take 24 + +newtype SbKey = SecretBoxKey {unSbKey :: ByteString} deriving (Eq, Show) +pattern SbKey :: ByteString -> SbKey +pattern SbKey s <- SecretBoxKey s + +{-# COMPLETE SbKey #-} + instance StrEncoding SbKey where strEncode (SbKey s) = strEncode s strP = sbKey <$> strP @@ -1002,25 +1020,21 @@ instance ToJSON SbKey where sbKey :: ByteString -> SbKey sbKey s - | len == 32 = SbKey s - | len > 32 = SbKey . fst $ B.splitAt 32 s - | otherwise = SbKey $ s <> B.replicate (32 - len) (toEnum 0) + | len == 32 = SecretBoxKey s + | len > 32 = SecretBoxKey . fst $ B.splitAt 32 s + | otherwise = SecretBoxKey $ s <> B.replicate (32 - len) (toEnum 0) where len = B.length s randomSbKey :: IO SbKey -randomSbKey = SbKey <$> getRandomBytes 32 - -instance Encoding CbNonce where - smpEncode = unCbNonce - smpP = CbNonce <$> A.take 24 +randomSbKey = SecretBoxKey <$> getRandomBytes 32 xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString) -xSalsa20 shared nonce msg = (rs, msg') +xSalsa20 secret nonce msg = (rs, msg') where zero = B.replicate 16 $ toEnum 0 (iv0, iv1) = B.splitAt 8 nonce - state0 = XSalsa.initialize 20 shared (zero `B.append` iv0) + state0 = XSalsa.initialize 20 secret (zero `B.append` iv0) state1 = XSalsa.derive state0 iv1 (rs, state2) = XSalsa.generate state1 32 (msg', _) = XSalsa.combine state2 msg diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs new file mode 100644 index 000000000..667c9a7c4 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/Lazy.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module Simplex.Messaging.Crypto.Lazy + ( sha512Hash, + pad, + unPad, + sbEncrypt, + sbDecrypt, + fastReplicate, + ) +where + +import qualified Crypto.Cipher.XSalsa as XSalsa +import qualified Crypto.Error as CE +import Crypto.Hash (Digest, hashlazy) +import Crypto.Hash.Algorithms (SHA512) +import qualified Crypto.MAC.Poly1305 as Poly1305 +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray as BA +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Int (Int64) +import Foreign (sizeOf) +import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), SbKey, pattern CbNonce, pattern SbKey) +import Simplex.Messaging.Encoding + +type LazyByteString = LB.ByteString + +-- | SHA512 digest of a lazy bytestring. +sha512Hash :: LazyByteString -> ByteString +sha512Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA512) + +-- this function does not validate the length of the message to avoid consuming all chunks, +-- but if the passed string is longer it will truncate it to specified length +pad :: LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +pad msg len paddedLen + | padLen >= 0 = Right $ LB.fromStrict encodedLen <> LB.take len msg <> fastReplicate padLen '#' + | otherwise = Left CryptoLargeMsgError + where + encodedLen = smpEncode len -- 8 bytes Int64 encoded length + padLen = paddedLen - len - 8 + +fastReplicate :: Int64 -> Char -> LazyByteString +fastReplicate n c + | n <= 0 = LB.empty + | n < chSize' = LB.fromStrict $ B.replicate (fromIntegral n) c + | otherwise = LB.fromChunks $ B.replicate (fromIntegral r) c : replicate (fromIntegral q) chPad + where + chSize = 65536 - 2 * sizeOf (undefined :: Int) + chPad = B.replicate chSize c + chSize' = fromIntegral chSize + (q, r) = quotRem n chSize' + +-- this function does not validate the length of the message to avoid consuming all chunks, +-- so it can return a shorter string than expected +unPad :: LazyByteString -> Either CryptoError LazyByteString +unPad padded + | LB.length lenStr == 8 = case smpDecode $ LB.toStrict lenStr of + Right len + | len < 0 -> Left CryptoInvalidMsgError + | otherwise -> Right $ LB.take len rest + Left _ -> Left CryptoInvalidMsgError + | otherwise = Left CryptoInvalidMsgError + where + (lenStr, rest) = LB.splitAt 8 padded + +-- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce. +sbEncrypt :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +sbEncrypt (SbKey key) = sbEncrypt_ key + +sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +sbEncrypt_ secret (CbNonce nonce) msg len paddedLen = cryptoBox secret nonce =<< pad msg len paddedLen + +-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce. +sbDecrypt :: SbKey -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString +sbDecrypt (SbKey key) = sbDecrypt_ key + +-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. +sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString +sbDecrypt_ secret (CbNonce nonce) packet + | LB.length tag' < 16 = Left CBDecryptError + | otherwise = case poly1305auth rs c of + Right tag + | BA.constEq (LB.toStrict tag') tag -> unPad msg + | otherwise -> Left CBDecryptError + Left e -> Left e + where + (tag', c) = LB.splitAt 16 packet + (rs, msg) = xSalsa20 secret nonce c + +cryptoBox :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> Either CryptoError LazyByteString +cryptoBox secret nonce s = (<> c) . LB.fromStrict . BA.convert <$> tag + where + (rs, c) = xSalsa20 secret nonce s + tag = poly1305auth rs c + +poly1305auth :: ByteString -> LazyByteString -> Either CryptoError Poly1305.Auth +poly1305auth rs c = authTag <$> cryptoPassed (Poly1305.initialize rs) + where + authTag state = Poly1305.finalize $ Poly1305.updates state $ LB.toChunks c + cryptoPassed = \case + CE.CryptoPassed a -> Right a + CE.CryptoFailed e -> Left $ CryptoPoly1305Error e + +xSalsa20 :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> (ByteString, LazyByteString) +xSalsa20 secret nonce msg = (rs, msg') + where + zero = B.replicate 16 $ toEnum 0 + (iv0, iv1) = B.splitAt 8 nonce + state0 = XSalsa.initialize 20 secret (zero `B.append` iv0) + state1 = XSalsa.derive state0 iv1 + (rs, state2) = XSalsa.generate state1 32 + (msg', _) = foldl update (LB.empty, state2) $ LB.toChunks msg + update (acc, state) chunk = + let (c, state') = XSalsa.combine state chunk + in (acc `LB.append` LB.fromStrict c, state') diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index e3b0060e1..5033b4e4e 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -4,10 +4,15 @@ module CoreTests.CryptoTests (cryptoTests) where import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isRight) +import Data.Int (Int64) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LE import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Lazy as LC import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -36,18 +41,58 @@ cryptoTests = do it "unpad should fail on shorter string" $ do C.unPad "\000\003abc" `shouldBe` Right "abc" C.unPad "\000\003ab" `shouldBe` Left C.CryptoInvalidMsgError + modifyMaxSuccess (const 10000) . describe "lazy padding / unpadding" $ do + it "should pad / unpad lazy bytestrings" . property $ \(s, paddedLen) -> + let b = LE.encodeUtf8 $ LT.pack s + len = LB.length b + padded = LC.pad b len paddedLen + in if len <= paddedLen - 8 + then (padded >>= LC.unPad) == Right b + else padded == Left C.CryptoLargeMsgError + it "pad should support large string" $ do + LC.pad "abc" 3 11 `shouldBe` Right "\000\000\000\000\000\000\000\003abc" + LC.pad "abc" 3 10 `shouldBe` Left C.CryptoLargeMsgError + let s = LB.replicate 100000 'a' + (LC.pad s 100000 100100 >>= LC.unPad) `shouldBe` Right s + (LC.pad s 100000 100008 >>= LC.unPad) `shouldBe` Right s + (LC.pad s 100000 100007 >>= LC.unPad) `shouldBe` Left C.CryptoLargeMsgError + it "pad should truncate string if a shorter length is passed and unpad incorrectly when longer length is passed" $ do + let s = LB.replicate 10000 'a' + (LC.pad s 9000 10100 >>= LC.unPad) `shouldBe` Right (LB.take 9000 s) + (LC.pad s 11000 11100 >>= LC.unPad) `shouldBe` Right (s <> LB.replicate 92 '#') -- 92 = pad size, it is not truncated in this case + it "unpad should fail on invalid string" $ do + LC.unPad "\000\000\000\000\000\000\000\000" `shouldBe` Right "" + LC.unPad "\000\000" `shouldBe` Left C.CryptoInvalidMsgError + LC.unPad "" `shouldBe` Left C.CryptoInvalidMsgError + it "unpad won't fail on shorter string" $ do + LC.unPad "\000\000\000\000\000\000\000\003abc" `shouldBe` Right "abc" + LC.unPad "\000\000\000\000\000\000\000\003ab" `shouldBe` Right "ab" + it "should pad / unpad file" testPadUnpadFile describe "Ed signatures" $ do describe "Ed25519" $ testSignature C.SEd25519 describe "Ed448" $ testSignature C.SEd448 - describe "DH X25519 + cryptobox" $ do - testDHCryptoBox - testSecretBox + describe "DH X25519 + cryptobox" testDHCryptoBox + describe "secretbox" testSecretBox + describe "lazy secretbox" $ do + testLazySecretBox + testLazySecretBoxFile describe "X509 key encoding" $ do describe "Ed25519" $ testEncoding C.SEd25519 describe "Ed448" $ testEncoding C.SEd448 describe "X25519" $ testEncoding C.SX25519 describe "X448" $ testEncoding C.SX448 +testPadUnpadFile :: IO () +testPadUnpadFile = do + let f = "tests/tmp/testpad" + paddedLen = 1024 * 1024 + len = 1000000 + s = LB.replicate len 'a' + Right s' <- pure $ LC.pad s len paddedLen + LB.writeFile (f <> ".padded") s' + Right s'' <- LC.unPad <$> LB.readFile (f <> ".padded") + s'' `shouldBe` s + testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec testSignature alg = it "should sign / verify string" . ioProperty $ do (k, pk) <- C.generateSignatureKeyPair alg @@ -71,11 +116,38 @@ testSecretBox = it "should encrypt / decrypt string with a random symmetric key" nonce <- C.randomCbNonce pure $ \(s, pad) -> let b = encodeUtf8 $ T.pack s - paddedLen = B.length b + abs pad + 2 + pad' = min (abs pad) 100000 + paddedLen = B.length b + pad' + 2 cipher = C.sbEncrypt k nonce b paddedLen plain = C.sbDecrypt k nonce =<< cipher in isRight cipher && cipher /= plain && Right b == plain +testLazySecretBox :: Spec +testLazySecretBox = it "should lazily encrypt / decrypt string with a random symmetric key" . ioProperty $ do + k <- C.randomSbKey + nonce <- C.randomCbNonce + pure $ \(s, pad) -> + let b = LE.encodeUtf8 $ LT.pack s + len = LB.length b + pad' = min (abs pad) 100000 + paddedLen = len + pad' + 8 + cipher = LC.sbEncrypt k nonce b len paddedLen + plain = LC.sbDecrypt k nonce =<< cipher + in isRight cipher && cipher /= plain && Right b == plain + +testLazySecretBoxFile :: Spec +testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random symmetric key" $ do + k <- C.randomSbKey + nonce <- C.randomCbNonce + let f = "tests/tmp/testsecretbox" + paddedLen = 4 * 1024 * 1024 + len = 4 * 1000 * 1000 :: Int64 + s = LC.fastReplicate len 'a' + Right s' <- pure $ LC.sbEncrypt k nonce s len paddedLen + LB.writeFile (f <> ".encrypted") s' + Right s'' <- LC.sbDecrypt k nonce <$> LB.readFile (f <> ".encrypted") + s'' `shouldBe` s + testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec testEncoding alg = it "should encode / decode key" . ioProperty $ do (k, pk) <- C.generateKeyPair alg