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

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