lazy pad/unpad, secretbox encrypt/decrypt (#639)

package.yaml

@@ -112,7 +112,7 @@ executables:
       - -threaded
 
 tests:
-  smp-server-test:
+  simplexmq-test:
     source-dirs: tests
     main: Test.hs
     dependencies:

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:

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

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')

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