diff --git a/package.yaml b/package.yaml index d4b74b400..727898864 100644 --- a/package.yaml +++ b/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.* diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index fe97b5355..400d4dbda 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/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) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index bdbd36cee..57e14dda0 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/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 " $ \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 " $ \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 + } diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index b84d0ee1f..1ca2a7717 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Transmission.hs b/src/Simplex/Messaging/Agent/Transmission.hs index 16ac4dd7e..5393ea14a 100644 --- a/src/Simplex/Messaging/Agent/Transmission.hs +++ b/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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index cda565d8b..3f01a1bdc 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/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 diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index d3c1b024f..ff437b146 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/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 diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index f79c38949..e8397015d 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/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 \ No newline at end of file +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) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index f2f2fc933..49e930a68 100644 --- a/tests/AgentTests.hs +++ b/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")