E2E message encryption (#38)

* RSA OAEP functions

* encrypt/decrypt using AES AEAD GSM

* fix JOIN syntax test

* encrypt/decrypt functions working

* e2e encryption!

* refactor monadic transitions

* rename liftError' to liftEitherError

* combine CryproFailable functions

package.yaml

@@ -20,6 +20,7 @@ dependencies:
   - containers
   - cryptonite == 0.26.*
   - iso8601-time == 0.1.*
+  - memory == 0.15.*
   - mtl
   - network == 3.1.*
   - simple-logger == 0.1.*

src/Simplex/Messaging/Agent.hs

@@ -36,6 +36,7 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (putLn, runTCPServer)
 import Simplex.Messaging.Types (CorrId (..), MsgBody, SenderPublicKey)
+import Simplex.Messaging.Util (liftError)
 import System.IO (Handle)
 import UnliftIO.Async (race_)
 import UnliftIO.Exception (SomeException)
@@ -275,8 +276,8 @@ connectToSendQueue c sq senderKey verifyKey = do
   sendHello c sq verifyKey
   withStore $ \st -> setSndQueueStatus st sq Active
 
-decryptMessage :: MonadUnliftIO m => DecryptionKey -> ByteString -> m ByteString
-decryptMessage _decryptKey = return
+decryptMessage :: (MonadUnliftIO m, MonadError AgentErrorType m) => DecryptionKey -> ByteString -> m ByteString
+decryptMessage decryptKey msg = liftError CRYPTO $ C.decrypt decryptKey msg
 
 newSendQueue ::
   (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> ConnAlias -> m (SendQueue, SenderPublicKey, VerificationKey)

src/Simplex/Messaging/Agent/Client.hs

@@ -32,7 +32,6 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Control.Monad.Trans.Except
-import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -50,6 +49,7 @@ import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (QueueId)
 import Simplex.Messaging.Types (ErrorType (AUTH), MsgBody, SenderPublicKey)
+import Simplex.Messaging.Util (liftError)
 import UnliftIO.Concurrent
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
@@ -125,9 +125,7 @@ withSMP c srv action =
   (getSMPServerClient c srv >>= runAction) `catchError` logServerError
   where
     runAction :: SMPClient -> m a
-    runAction smp =
-      liftIO (first smpClientError <$> runExceptT (action smp))
-        >>= liftEither
+    runAction smp = liftError smpClientError $ action smp
 
     smpClientError :: SMPClientError -> AgentErrorType
     smpClientError = \case
@@ -209,7 +207,7 @@ logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
 
 sendConfirmation :: forall m. AgentMonad m => AgentClient -> SendQueue -> SenderPublicKey -> m ()
-sendConfirmation c SendQueue {server, sndId} senderKey = do
+sendConfirmation c SendQueue {server, sndId, encryptKey} senderKey = do
   msg <- mkConfirmation
   withLogSMP c server sndId "SEND <KEY>" $ \smp ->
     sendSMPMessage smp Nothing sndId msg
@@ -217,8 +215,7 @@ sendConfirmation c SendQueue {server, sndId} senderKey = do
     mkConfirmation :: m MsgBody
     mkConfirmation = do
       let msg = serializeSMPMessage $ SMPConfirmation senderKey
-      -- TODO encryption
-      return msg
+      liftError CRYPTO $ C.encrypt encryptKey msg
 
 sendHello :: forall m. AgentMonad m => AgentClient -> SendQueue -> VerificationKey -> m ()
 sendHello c SendQueue {server, sndId, sndPrivateKey, encryptKey} verifyKey = do
@@ -227,8 +224,7 @@ sendHello c SendQueue {server, sndId, sndPrivateKey, encryptKey} verifyKey = do
     send 20 msg
   where
     mkHello :: AckMode -> m ByteString
-    mkHello ackMode =
-      mkAgentMessage encryptKey $ HELLO verifyKey ackMode
+    mkHello ackMode = mkAgentMessage encryptKey $ HELLO verifyKey ackMode
 
     send :: Int -> ByteString -> SMPClient -> ExceptT SMPClientError IO ()
     send 0 _ _ = throwE SMPResponseTimeout -- TODO different error
@@ -265,16 +261,16 @@ sendAgentMessage c SendQueue {server, sndId, sndPrivateKey, encryptKey} agentMsg
   withLogSMP c server sndId "SEND <message>" $ \smp ->
     sendSMPMessage smp (Just sndPrivateKey) sndId msg
 
-mkAgentMessage :: MonadUnliftIO m => EncryptionKey -> AMessage -> m ByteString
-mkAgentMessage _encKey agentMessage = do
-  senderTimestamp <- liftIO getCurrentTime
-  let msg =
-        serializeSMPMessage
-          SMPMessage
-            { senderMsgId = 0,
-              senderTimestamp,
-              previousMsgHash = "1234", -- TODO hash of the previous message
-              agentMessage
-            }
-  -- TODO encryption
-  return msg
+mkAgentMessage :: (MonadUnliftIO m, MonadError AgentErrorType m) => EncryptionKey -> AMessage -> m ByteString
+mkAgentMessage encKey agentMessage = do
+  ts <- liftIO getCurrentTime
+  liftError CRYPTO $ C.encrypt encKey $ msg ts
+  where
+    msg ts =
+      serializeSMPMessage
+        SMPMessage
+          { senderMsgId = 0,
+            senderTimestamp = ts,
+            previousMsgHash = "1234", -- TODO hash of the previous message
+            agentMessage
+          }

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -19,6 +19,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Util
 import Simplex.Messaging.Agent.Store.Types
 import Simplex.Messaging.Agent.Transmission
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Util (liftIOEither)
 
 data SQLiteStore = SQLiteStore
   { dbFilename :: String,
@@ -69,15 +70,13 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
 
   upgradeRcvConnToDuplex :: SQLiteStore -> ConnAlias -> SendQueue -> m ()
   upgradeRcvConnToDuplex SQLiteStore {dbConn} connAlias sndQueue =
-    liftIO
-      (updateRcvConnWithSndQueue dbConn connAlias sndQueue)
-      >>= liftEither
+    liftIOEither $
+      updateRcvConnWithSndQueue dbConn connAlias sndQueue
 
   upgradeSndConnToDuplex :: SQLiteStore -> ConnAlias -> ReceiveQueue -> m ()
   upgradeSndConnToDuplex SQLiteStore {dbConn} connAlias rcvQueue =
-    liftIO
-      (updateSndConnWithRcvQueue dbConn connAlias rcvQueue)
-      >>= liftEither
+    liftIOEither $
+      updateSndConnWithRcvQueue dbConn connAlias rcvQueue
 
   removeSndAuth :: SQLiteStore -> ConnAlias -> m ()
   removeSndAuth _st _connAlias = throwError SENotImplemented
@@ -94,9 +93,8 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
 
   createMsg :: SQLiteStore -> ConnAlias -> QueueDirection -> AgentMsgId -> AMessage -> m ()
   createMsg SQLiteStore {dbConn} connAlias qDirection agentMsgId aMsg =
-    liftIO
-      (insertMsg dbConn connAlias agentMsgId aMsg)
-      >>= liftEither
+    liftIOEither $
+      insertMsg dbConn connAlias agentMsgId aMsg
     where
       insertMsg = case qDirection of
         RCV -> insertRcvMsg

src/Simplex/Messaging/Agent/Transmission.hs

@@ -245,6 +245,7 @@ data AgentErrorType
   | SYNTAX Int
   | BROKER Natural
   | SMP ErrorType
+  | CRYPTO C.CryptoError
   | SIZE
   | STORE StoreError
   | INTERNAL -- etc. TODO SYNTAX Natural

src/Simplex/Messaging/Client.hs

@@ -47,7 +47,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Types
-import Simplex.Messaging.Util
+import Simplex.Messaging.Util (liftEitherError, raceAny_)
 import System.IO
 import System.IO.Error
 import System.Timeout
@@ -237,7 +237,7 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = do
     signTransmission t = case pKey of
       Nothing -> return ("", t)
       Just pk -> do
-        sig <- ExceptT (C.sign pk t) `catchE` (throwE . SMPCryptoError)
+        sig <- liftEitherError SMPCryptoError $ C.sign pk t
         return (sig, t)
 
     -- two separate "atomically" needed to avoid blocking

src/Simplex/Messaging/Crypto.hs

@@ -1,13 +1,21 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Crypto
   ( PrivateKey (..),
     PublicKey (..),
     Signature (..),
+    CryptoError (..),
     generateKeyPair,
     sign,
     verify,
+    encrypt,
+    decrypt,
     serializePrivKey,
     serializePubKey,
     parsePrivKey,
@@ -17,16 +25,28 @@ module Simplex.Messaging.Crypto
   )
 where
 
+import Control.Exception (Exception)
+import Control.Monad.Except
+import Control.Monad.Trans.Except
+import Crypto.Cipher.AES (AES256)
+import qualified Crypto.Cipher.Types as AES
+import qualified Crypto.Error as CE
 import Crypto.Hash.Algorithms (SHA256 (..))
 import Crypto.Number.Generate (generateMax)
 import Crypto.Number.Prime (findPrimeFrom)
 import Crypto.Number.Serialize (i2osp, os2ip)
 import qualified Crypto.PubKey.RSA as R
+import qualified Crypto.PubKey.RSA.OAEP as OAEP
 import qualified Crypto.PubKey.RSA.PSS as PSS
+import Crypto.Random (getRandomBytes)
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import qualified Data.ByteArray as BA
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Internal (c2w, w2c)
 import Data.String
 import Database.SQLite.Simple as DB
 import Database.SQLite.Simple.FromField
@@ -34,9 +54,9 @@ import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
 import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Parsers (base64P)
-import Simplex.Messaging.Util (bshow, (<$$>))
+import Simplex.Messaging.Util (bshow, liftEitherError, (<$$>))
 
-newtype PublicKey = PublicKey R.PublicKey deriving (Eq, Show)
+newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show)
 
 data PrivateKey = PrivateKey
   { private_size :: Int,
@@ -72,25 +92,94 @@ instance IsString Signature where
 
 newtype Verified = Verified ByteString deriving (Show)
 
+data CryptoError
+  = CryptoRSAError R.Error
+  | CryptoCipherError CE.CryptoError
+  | CryptoIVError
+  | CryptoDecryptError
+  deriving (Eq, Show, Exception)
+
 pubExpRange :: Integer
 pubExpRange = 2 ^ (1024 :: Int)
 
 generateKeyPair :: Int -> IO KeyPair
 generateKeyPair size = loop
   where
+    publicExponent = findPrimeFrom . (+ 3) <$> generateMax pubExpRange
+    privateKey s n d = PrivateKey {private_size = s, private_n = n, private_d = d}
     loop = do
       (pub, priv) <- R.generate size =<< publicExponent
-      let n = R.public_n pub
+      let s = R.public_size pub
+          n = R.public_n pub
           d = R.private_d priv
        in if d * d < n
             then loop
-            else
-              return
-                ( PublicKey pub,
-                  -- TODO add comments explaining why we throw away public key from private
-                  PrivateKey {private_size = R.public_size pub, private_n = n, private_d = d}
-                )
-    publicExponent = findPrimeFrom . (+ 3) <$> generateMax pubExpRange
+            else return (PublicKey pub, privateKey s n d)
+
+encrypt :: PublicKey -> ByteString -> ExceptT CryptoError IO ByteString
+encrypt k msg = do
+  aesKey <- randomBytes 32
+  ivBytes <- randomIVBytes @AES256
+  aead <- initAEAD @AES256 (aesKey, ivBytes)
+  let (authTag, msg') = encryptAES aead msg
+  encKeyIv <- encryptOAEP k (aesKey <> ivBytes)
+  return $ encKeyIv <> authTagToBS authTag <> msg'
+
+decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString
+decrypt pk msg'' = do
+  let (encKeyIv, msg') = B.splitAt (private_size pk) msg''
+      (authTag, msg) = B.splitAt 16 msg'
+  keyIv <- B.splitAt 32 <$> decryptOAEP pk encKeyIv
+  aead <- initAEAD @AES256 keyIv
+  decryptAES aead msg (bsToAuthTag authTag)
+
+encryptAES :: AES.AEAD AES256 -> ByteString -> (AES.AuthTag, ByteString)
+encryptAES aead plaintext = AES.aeadSimpleEncrypt aead B.empty plaintext 16
+
+decryptAES :: AES.AEAD AES256 -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString
+decryptAES aead ciphertext authTag =
+  maybeError CryptoDecryptError $ AES.aeadSimpleDecrypt aead B.empty ciphertext authTag
+
+initAEAD :: forall c. AES.BlockCipher c => (ByteString, ByteString) -> ExceptT CryptoError IO (AES.AEAD c)
+initAEAD (aesKey, ivBytes) = do
+  iv <- makeIV @c ivBytes
+  cryptoFailable $ do
+    cipher <- AES.cipherInit aesKey
+    AES.aeadInit AES.AEAD_GCM cipher iv
+
+randomIVBytes :: forall c. AES.BlockCipher c => ExceptT CryptoError IO ByteString
+randomIVBytes = randomBytes (AES.blockSize (undefined :: c))
+
+makeIV :: AES.BlockCipher c => ByteString -> ExceptT CryptoError IO (AES.IV c)
+makeIV bs = maybeError CryptoIVError $ AES.makeIV bs
+
+randomBytes :: Int -> ExceptT CryptoError IO ByteString
+randomBytes n = ExceptT $ Right <$> getRandomBytes n
+
+maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a
+maybeError e = maybe (throwE e) return
+
+authTagToBS :: AES.AuthTag -> ByteString
+authTagToBS = B.pack . map w2c . BA.unpack . AES.unAuthTag
+
+bsToAuthTag :: ByteString -> AES.AuthTag
+bsToAuthTag = AES.AuthTag . BA.pack . map c2w . B.unpack
+
+cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a
+cryptoFailable = liftEither . first CryptoCipherError . CE.eitherCryptoError
+
+oaepParams :: OAEP.OAEPParams SHA256 ByteString ByteString
+oaepParams = OAEP.defaultOAEPParams SHA256
+
+encryptOAEP :: PublicKey -> ByteString -> ExceptT CryptoError IO ByteString
+encryptOAEP (PublicKey k) aesKey =
+  liftEitherError CryptoRSAError $
+    OAEP.encrypt oaepParams k aesKey
+
+decryptOAEP :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString
+decryptOAEP pk encKey =
+  liftEitherError CryptoRSAError $
+    OAEP.decryptSafer oaepParams (rsaPrivateKey pk) encKey
 
 pssParams :: PSS.PSSParams SHA256 ByteString ByteString
 pssParams = PSS.defaultPSSParams SHA256

src/Simplex/Messaging/Util.hs

@@ -6,11 +6,12 @@ module Simplex.Messaging.Util where
 
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
+import Data.Bifunctor (first)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import UnliftIO.Async
 import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
 
 newtype InternalException e = InternalException {unInternalException :: e}
   deriving (Eq, Show)
@@ -36,4 +37,13 @@ infixl 4 <$$>
 (<$$>) = fmap . fmap
 
 bshow :: Show a => a -> ByteString
-bshow = B.pack . show
+bshow = B.pack . show
+
+liftIOEither :: (MonadUnliftIO m, MonadError e m) => IO (Either e a) -> m a
+liftIOEither a = liftIO a >>= liftEither
+
+liftError :: (MonadUnliftIO m, MonadError e' m) => (e -> e') -> ExceptT e IO a -> m a
+liftError f = liftEitherError f . runExceptT
+
+liftEitherError :: (MonadUnliftIO m, MonadError e' m) => (e -> e') -> IO (Either e a) -> m a
+liftEitherError f a = liftIOEither (first f <$> a)

tests/AgentTests.hs

@@ -123,6 +123,9 @@ testSubscrNotification (server, _) client = do
   killThread server
   client <# ("", "conn1", END)
 
+samplePublicKey :: ByteString
+samplePublicKey = "128,2Qq2UNh5JuScgW0twxeYIDm8Uqf+b7t7OsUQcAgmDBpD+S4ZVoika1SxN2KsCSd7VneWMHm89oXIcGYM7jC7uJE8zXJFIr/1PimF96ols7n6UUFOSTH3VSqe47CzQfamxTFHl463fNPLbvOLxRfkzrZ5Qkpk2LyMkje8R1/39n0=,/uSFqPtYQeK/CX8qK4XR1BOt8eL+axBWgX7tGosI8VFBoBWR4Cbtx+F3hInQVCpxoQsz6n76ppWD4PSnzqcvQudD/3eo8VQNdQpBtX0vOjtsOxycselo99k2mdixIjjUz/RDR1Z+OthCG3rGeIK5/wyERcLR7EsBGOaBr+Xidbs="
+
 syntaxTests :: Spec
 syntaxTests = do
   it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR SYNTAX 11")
@@ -141,11 +144,11 @@ syntaxTests = do
       it "invalid server keyHash" $ ("223", "", "NEW localhost:5000#1") >#> ("223", "", "ERR SYNTAX 11")
 
   describe "JOIN" do
-    xdescribe "valid" do
+    describe "valid" do
       -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided)
       -- TODO: add tests with defined connection alias
       it "using same server as in invitation" $
-        ("311", "", "JOIN smp::localhost:5000::1234::5678") >#> ("311", "", "ERR SMP AUTH")
+        ("311", "", "JOIN smp::localhost:5000::1234::" <> samplePublicKey) >#> ("311", "", "ERR SMP AUTH")
     describe "invalid" do
       -- TODO: JOIN is not merged yet - to be added
       it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR SYNTAX 11")