transport encryption (#65)

* transport encryption (WIP - using fixed key, parsing/serialization works, SMP tests fail)

* transport encryption

* transport encryption: separate keys to receive and to send, counter-based IVs

* docs: update transport encryption and handshake

* transport encryption handshake (TODO: validate key hash, welcome block, move keys to system environment)

* change KeyHash type to newtype of Digest SHA256

* transport encryption: validate public key hash

* send and receive welcome block with SMP version

* refactor: parsing SMPServer

* remove unused function

* verify that client version is compatible with server version (major version is not smaller)

* update (fix) SMP server tests

src/Simplex/Messaging/Agent.hs

@@ -35,7 +35,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (CorrId (..), MsgBody, SenderPublicKey)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (putLn, runTCPServer)
-import Simplex.Messaging.Util (liftError)
+import Simplex.Messaging.Util (bshow, liftError)
 import System.IO (Handle)
 import UnliftIO.Async (race_)
 import UnliftIO.Exception (SomeException)
@@ -94,7 +94,7 @@ send h c@AgentClient {sndQ} = forever $ do
 
 logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
 logClient AgentClient {clientId} dir (CorrId corrId, cAlias, cmd) = do
-  logInfo . decodeUtf8 $ B.unwords [B.pack $ show clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd]
+  logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd]
 
 client :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m ()
 client c@AgentClient {rcvQ, sndQ} st = forever $ do
@@ -278,7 +278,7 @@ processSMPTransmission c@AgentClient {sndQ} st (srv, rId, cmd) = do
       removeSubscription c connAlias
       logServer "<--" c srv rId "END"
       notify connAlias END
-    _ -> logServer "<--" c srv rId $ "unexpected:" <> (B.pack . show) cmd
+    _ -> logServer "<--" c srv rId $ "unexpected:" <> bshow cmd
   where
     notify :: ConnAlias -> ACommand 'Agent -> m ()
     notify connAlias msg = atomically $ writeTBQueue sndQ ("", connAlias, msg)

src/Simplex/Messaging/Agent/Client.hs

@@ -47,7 +47,7 @@ import Simplex.Messaging.Agent.Transmission
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey)
-import Simplex.Messaging.Util (liftError)
+import Simplex.Messaging.Util (bshow, liftError)
 import UnliftIO.Concurrent
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
@@ -133,7 +133,7 @@ withSMP c srv action =
 
     logServerError :: AgentErrorType -> m a
     logServerError e = do
-      logServer "<--" c srv "" $ (B.pack . show) e
+      logServer "<--" c srv "" $ bshow e
       throwError e
 
 withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
@@ -196,7 +196,7 @@ removeSubscription AgentClient {subscrConns, subscrSrvrs} connAlias = atomically
 
 logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
-  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> (B.pack . show) clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
+  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
 
 showServer :: SMPServer -> ByteString
 showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv)

src/Simplex/Messaging/Agent/Transmission.hs

@@ -152,7 +152,7 @@ serializeSMPMessage = \case
      in smpMessage "" header body
   where
     messageHeader msgId ts prevMsgHash =
-      B.unwords [B.pack $ show msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash]
+      B.unwords [bshow msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash]
     smpMessage smpHeader aHeader aBody = B.intercalate "\n" [smpHeader, aHeader, aBody, ""]
 
 agentMessageP :: Parser AMessage
@@ -173,11 +173,17 @@ smpQueueInfoP =
   "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP)
 
 smpServerP :: Parser SMPServer
-smpServerP = SMPServer <$> server <*> port <*> msgHash
+smpServerP = SMPServer <$> server <*> port <*> kHash
   where
     server = B.unpack <$> A.takeTill (A.inClass ":# ")
-    port = A.char ':' *> (Just . show <$> (A.decimal :: Parser Int)) <|> pure Nothing
-    msgHash = A.char '#' *> (Just <$> base64P) <|> pure Nothing
+    port = fromChar ':' $ show <$> (A.decimal :: Parser Int)
+    kHash = fromChar '#' C.keyHashP
+    fromChar :: Char -> Parser a -> Parser (Maybe a)
+    fromChar ch parser = do
+      c <- A.peekChar
+      if c == Just ch
+        then A.char ch *> (Just <$> parser)
+        else pure Nothing
 
 parseAgentMessage :: ByteString -> Either AgentErrorType AMessage
 parseAgentMessage = parse agentMessageP $ SYNTAX errBadMessage
@@ -194,17 +200,15 @@ serializeSmpQueueInfo (SMPQueueInfo srv qId ek) =
 
 serializeServer :: SMPServer -> ByteString
 serializeServer SMPServer {host, port, keyHash} =
-  B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack) keyHash
+  B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . C.serializeKeyHash) keyHash
 
 data SMPServer = SMPServer
   { host :: HostName,
     port :: Maybe ServiceName,
-    keyHash :: Maybe KeyHash
+    keyHash :: Maybe C.KeyHash
   }
   deriving (Eq, Ord, Show)
 
-type KeyHash = Encoded
-
 type ConnAlias = ByteString
 
 type OtherPartyId = Encoded
@@ -354,7 +358,7 @@ serializeCommand = \case
   OFF -> "OFF"
   DEL -> "DEL"
   CON -> "CON"
-  ERR e -> "ERR " <> B.pack (show e)
+  ERR e -> "ERR " <> bshow e
   OK -> "OK"
   where
     replyMode :: ReplyMode -> ByteString
@@ -370,13 +374,13 @@ serializeCommand = \case
       MsgError e ->
         "ERR" <> case e of
           MsgSkipped fromMsgId toMsgId ->
-            B.unwords ["NO_ID", B.pack $ show fromMsgId, B.pack $ show toMsgId]
-          MsgBadId aMsgId -> "ID " <> B.pack (show aMsgId)
+            B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId]
+          MsgBadId aMsgId -> "ID " <> bshow aMsgId
           MsgBadHash -> "HASH"
 
 -- TODO - save function as in the server Transmission - re-use?
 serializeMsg :: ByteString -> ByteString
-serializeMsg body = B.pack (show $ B.length body) <> "\n" <> body
+serializeMsg body = bshow (B.length body) <> "\n" <> body
 
 tPutRaw :: Handle -> ARawTransmission -> IO ()
 tPutRaw h (corrId, connAlias, command) = do

src/Simplex/Messaging/Client.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -35,7 +36,6 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import qualified Crypto.PubKey.RSA.Types as RSA
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -46,7 +46,7 @@ import Simplex.Messaging.Agent.Transmission (SMPServer (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (liftEitherError, raceAny_)
+import Simplex.Messaging.Util (bshow, liftEitherError, raceAny_)
 import System.IO
 import System.IO.Error
 import System.Timeout
@@ -91,7 +91,7 @@ data Request = Request
 
 getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO SMPClient
 getSMPClient
-  smpServer@SMPServer {host, port}
+  smpServer@SMPServer {host, port, keyHash}
   SMPClientConfig {qSize, defaultPort, tcpTimeout, smpPing}
   msgQ
   disconnected = do
@@ -103,7 +103,7 @@ getSMPClient
           `finally` atomically (putTMVar started False)
     tcpTimeout `timeout` atomically (takeTMVar started) >>= \case
       Just True -> return c {action}
-      _ -> throwIO err
+      _ -> throwIO err -- TODO report handshake error too, not only connection timeout
     where
       err :: IOException
       err = mkIOError TimeExpired "connection timeout" Nothing Nothing
@@ -128,18 +128,24 @@ getSMPClient
             }
 
       client :: SMPClient -> TMVar Bool -> Handle -> IO ()
-      client c started h = do
-        _ <- getLn h -- "Welcome to SMP"
+      client c started h =
+        runExceptT (clientHandshake h keyHash) >>= \case
+          Right th -> clientTransport c started th
+          -- TODO report error instead of True/False
+          Left _ -> atomically $ putTMVar started False
+
+      clientTransport :: SMPClient -> TMVar Bool -> THandle -> IO ()
+      clientTransport c started th = do
         atomically $ do
-          modifyTVar (connected c) (const True)
+          writeTVar (connected c) True
           putTMVar started True
-        raceAny_ [send c h, process c, receive c h, ping c]
+        raceAny_ [send c th, process c, receive c th, ping c]
           `finally` disconnected
 
-      send :: SMPClient -> Handle -> IO ()
+      send :: SMPClient -> THandle -> IO ()
       send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
-      receive :: SMPClient -> Handle -> IO ()
+      receive :: SMPClient -> THandle -> IO ()
       receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ
 
       ping :: SMPClient -> IO ()
@@ -241,7 +247,7 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = do
     getNextCorrId = do
       i <- (+ 1) <$> readTVar clientCorrId
       writeTVar clientCorrId i
-      return . CorrId . B.pack $ show i
+      return . CorrId $ bshow i
 
     signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission
     signTransmission t = case pKey of

src/Simplex/Messaging/Crypto.hs

@@ -10,17 +10,33 @@ module Simplex.Messaging.Crypto
     PublicKey (..),
     Signature (..),
     CryptoError (..),
+    KeyPair,
+    Key (..),
+    IV (..),
+    KeyHash (..),
     generateKeyPair,
+    publicKeySize,
     sign,
     verify,
     encrypt,
     decrypt,
+    encryptOAEP,
+    decryptOAEP,
+    encryptAES,
+    decryptAES,
     serializePrivKey,
     serializePubKey,
-    parsePrivKey,
-    parsePubKey,
+    serializeKeyHash,
     privKeyP,
     pubKeyP,
+    keyHashP,
+    authTagSize,
+    authTagToBS,
+    bsToAuthTag,
+    randomAesKey,
+    randomIV,
+    aesKeyP,
+    ivP,
   )
 where
 
@@ -30,7 +46,7 @@ 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.Hash (Digest, SHA256 (..), digestFromByteString)
 import Crypto.Number.Generate (generateMax)
 import Crypto.Number.Prime (findPrimeFrom)
 import Crypto.Number.Serialize (i2osp, os2ip)
@@ -53,7 +69,7 @@ import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
 import Database.SQLite.Simple.ToField (ToField (..))
 import Network.Transport.Internal (decodeWord32, encodeWord32)
-import Simplex.Messaging.Parsers (base64P)
+import Simplex.Messaging.Parsers (base64P, parseAll)
 import Simplex.Messaging.Util (bshow, liftEitherError, (<$$>))
 
 newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show)
@@ -71,14 +87,14 @@ instance ToField PublicKey where toField = toField . serializePubKey
 
 instance FromField PrivateKey where
   fromField f@(Field (SQLBlob b) _) =
-    case parsePrivKey b of
+    case parseAll privKeyP b of
       Right k -> Ok k
       Left e -> returnError ConversionFailed f ("couldn't parse PrivateKey field: " ++ e)
   fromField f = returnError ConversionFailed f "expecting SQLBlob column type"
 
 instance FromField PublicKey where
   fromField f@(Field (SQLBlob b) _) =
-    case parsePubKey b of
+    case parseAll pubKeyP b of
       Right k -> Ok k
       Left e -> returnError ConversionFailed f ("couldn't parse PublicKey field: " ++ e)
   fromField f = returnError ConversionFailed f "expecting SQLBlob column type"
@@ -124,6 +140,9 @@ generateKeyPair size = loop
             then loop
             else return (PublicKey pub, privateKey s n d)
 
+publicKeySize :: PublicKey -> Int
+publicKeySize = R.public_size . rsaPublicKey
+
 data Header = Header
   { aesKey :: Key,
     ivBytes :: IV,
@@ -135,52 +154,83 @@ newtype Key = Key {unKey :: ByteString}
 
 newtype IV = IV {unIV :: ByteString}
 
+newtype KeyHash = KeyHash {unKeyHash :: Digest SHA256} deriving (Eq, Ord, Show)
+
+instance IsString KeyHash where
+  fromString = either error id . parseAll keyHashP . fromString
+
+instance ToField KeyHash where toField = toField . serializeKeyHash
+
+instance FromField KeyHash where
+  fromField f@(Field (SQLBlob b) _) =
+    case parseAll keyHashP b of
+      Right k -> Ok k
+      Left e -> returnError ConversionFailed f ("couldn't parse KeyHash field: " ++ e)
+  fromField f = returnError ConversionFailed f "expecting SQLBlob column type"
+
+serializeKeyHash :: KeyHash -> ByteString
+serializeKeyHash = encode . BA.convert . unKeyHash
+
+keyHashP :: Parser KeyHash
+keyHashP = do
+  bs <- base64P
+  case digestFromByteString bs of
+    Just d -> pure $ KeyHash d
+    _ -> fail "invalid digest"
+
 serializeHeader :: Header -> ByteString
 serializeHeader Header {aesKey, ivBytes, authTag, msgSize} =
   unKey aesKey <> unIV ivBytes <> authTagToBS authTag <> (encodeWord32 . fromIntegral) msgSize
 
 headerP :: Parser Header
 headerP = do
-  aesKey <- Key <$> A.take aesKeySize
-  ivBytes <- IV <$> A.take (ivSize @AES256)
+  aesKey <- aesKeyP
+  ivBytes <- ivP
   authTag <- bsToAuthTag <$> A.take authTagSize
   msgSize <- fromIntegral . decodeWord32 <$> A.take 4
   return Header {aesKey, ivBytes, authTag, msgSize}
 
+aesKeyP :: Parser Key
+aesKeyP = Key <$> A.take aesKeySize
+
+ivP :: Parser IV
+ivP = IV <$> A.take (ivSize @AES256)
+
 parseHeader :: ByteString -> Either CryptoError Header
-parseHeader = first CryptoHeaderError . A.parseOnly (headerP <* A.endOfInput)
+parseHeader = first CryptoHeaderError . parseAll headerP
 
 encrypt :: PublicKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString
 encrypt k paddedSize msg = do
-  aesKey <- Key <$> randomBytes aesKeySize
-  ivBytes <- IV <$> randomBytes (ivSize @AES256)
+  aesKey <- liftIO randomAesKey
+  ivBytes <- liftIO randomIV
+  (authTag, msg') <- encryptAES aesKey ivBytes paddedSize msg
+  let header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg}
+  encHeader <- encryptOAEP k $ serializeHeader header
+  return $ encHeader <> msg'
+
+decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString
+decrypt pk msg'' = do
+  let (encHeader, msg') = B.splitAt (private_size pk) msg''
+  header <- decryptOAEP pk encHeader
+  Header {aesKey, ivBytes, authTag, msgSize} <- except $ parseHeader header
+  msg <- decryptAES aesKey ivBytes msg' authTag
+  return $ B.take msgSize msg
+
+encryptAES :: Key -> IV -> Int -> ByteString -> ExceptT CryptoError IO (AES.AuthTag, ByteString)
+encryptAES aesKey ivBytes paddedSize msg = do
   aead <- initAEAD @AES256 aesKey ivBytes
   msg' <- paddedMsg
-  let (authTag, msg'') = encryptAES aead msg'
-      header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg}
-  encHeader <- encryptOAEP k $ serializeHeader header
-  return $ encHeader <> msg''
+  return $ AES.aeadSimpleEncrypt aead B.empty msg' authTagSize
   where
     len = B.length msg
     paddedMsg
       | len >= paddedSize = throwE CryptoLargeMsgError
       | otherwise = return (msg <> B.replicate (paddedSize - len) '#')
 
-decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString
-decrypt pk msg'' = do
-  let (encHeader, msg') = B.splitAt (private_size pk) msg''
-  header <- decryptOAEP pk encHeader
-  Header {aesKey, ivBytes, authTag, msgSize} <- ExceptT . return $ parseHeader header
+decryptAES :: Key -> IV -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString
+decryptAES aesKey ivBytes msg authTag = do
   aead <- initAEAD @AES256 aesKey ivBytes
-  msg <- decryptAES aead msg' authTag
-  return $ B.take msgSize msg
-
-encryptAES :: AES.AEAD AES256 -> ByteString -> (AES.AuthTag, ByteString)
-encryptAES aead plaintext = AES.aeadSimpleEncrypt aead B.empty plaintext authTagSize
-
-decryptAES :: AES.AEAD AES256 -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString
-decryptAES aead ciphertext authTag =
-  maybeError CryptoDecryptError $ AES.aeadSimpleDecrypt aead B.empty ciphertext authTag
+  maybeError CryptoDecryptError $ AES.aeadSimpleDecrypt aead B.empty msg authTag
 
 initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEAD (Key aesKey) (IV ivBytes) = do
@@ -189,15 +239,18 @@ initAEAD (Key aesKey) (IV ivBytes) = do
     cipher <- AES.cipherInit aesKey
     AES.aeadInit AES.AEAD_GCM cipher iv
 
+randomAesKey :: IO Key
+randomAesKey = Key <$> getRandomBytes aesKeySize
+
+randomIV :: IO IV
+randomIV = IV <$> getRandomBytes (ivSize @AES256)
+
 ivSize :: forall c. AES.BlockCipher c => Int
 ivSize = 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
 
@@ -253,12 +306,6 @@ privKeyP = do
   (private_size, private_n, private_d) <- keyParser_
   return PrivateKey {private_size, private_n, private_d}
 
-parsePubKey :: ByteString -> Either String PublicKey
-parsePubKey = A.parseOnly (pubKeyP <* A.endOfInput)
-
-parsePrivKey :: ByteString -> Either String PrivateKey
-parsePrivKey = A.parseOnly (privKeyP <* A.endOfInput)
-
 keyParser_ :: Parser (Int, Integer, Integer)
 keyParser_ = (,,) <$> (A.decimal <* ",") <*> (intP <* ",") <*> intP
   where

src/Simplex/Messaging/Parsers.hs

@@ -20,4 +20,7 @@ tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill (== ' ')
 
 parse :: Parser a -> e -> (ByteString -> Either e a)
-parse parser err = first (const err) . A.parseOnly (parser <* A.endOfInput)
+parse parser err = first (const err) . parseAll parser
+
+parseAll :: Parser a -> (ByteString -> Either String a)
+parseAll parser = A.parseOnly (parser <* A.endOfInput)

src/Simplex/Messaging/Protocol.hs

@@ -13,7 +13,7 @@ module Simplex.Messaging.Protocol where
 
 import Control.Applicative ((<|>))
 import Control.Monad
-import Control.Monad.IO.Class
+import Control.Monad.Except
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Base64
@@ -28,8 +28,6 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Util
-import System.IO
-import Text.Read
 
 data Party = Broker | Recipient | Sender
   deriving (Show)
@@ -108,7 +106,7 @@ type MsgId = Encoded
 
 type MsgBody = ByteString
 
-data ErrorType = PROHIBITED | SYNTAX Int | SIZE | AUTH | INTERNAL | DUPLICATE deriving (Show, Eq)
+data ErrorType = PROHIBITED | SYNTAX Int | AUTH | INTERNAL | DUPLICATE deriving (Show, Eq)
 
 errBadTransmission :: Int
 errBadTransmission = 1
@@ -128,6 +126,16 @@ errNoQueueId = 5
 errMessageBody :: Int
 errMessageBody = 6
 
+transmissionP :: Parser RawTransmission
+transmissionP = do
+  signature <- segment
+  corrId <- segment
+  queueId <- segment
+  command <- A.takeByteString
+  return (signature, corrId, queueId, command)
+  where
+    segment = A.takeTill (== ' ') <* " "
+
 commandP :: Parser Cmd
 commandP =
   "NEW " *> newCmd
@@ -148,60 +156,47 @@ commandP =
     newCmd = Cmd SRecipient . NEW <$> C.pubKeyP
     idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P)
     keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP
-    sendCmd = Cmd SSender . SEND <$> A.takeWhile A.isDigit
+    sendCmd = do
+      size <- A.decimal <* A.space
+      Cmd SSender . SEND <$> A.take size <* A.space
     message = do
       msgId <- base64P <* A.space
       ts <- tsISO8601P <* A.space
-      Cmd SBroker . MSG msgId ts <$> A.takeWhile A.isDigit
+      size <- A.decimal <* A.space
+      Cmd SBroker . MSG msgId ts <$> A.take size <* A.space
     serverError = Cmd SBroker . ERR <$> errorType
     errorType =
       "PROHIBITED" $> PROHIBITED
         <|> "SYNTAX " *> (SYNTAX <$> A.decimal)
-        <|> "SIZE" $> SIZE
         <|> "AUTH" $> AUTH
         <|> "INTERNAL" $> INTERNAL
 
+-- TODO ignore the end of block, no need to parse it
 parseCommand :: ByteString -> Either ErrorType Cmd
-parseCommand = parse commandP $ SYNTAX errBadSMPCommand
+parseCommand = parse (commandP <* " " <* A.takeByteString) $ SYNTAX errBadSMPCommand
 
 serializeCommand :: Cmd -> ByteString
 serializeCommand = \case
   Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey
   Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey
-  Cmd SRecipient cmd -> B.pack $ show cmd
-  Cmd SSender (SEND msgBody) -> "SEND" <> serializeMsg msgBody
+  Cmd SRecipient cmd -> bshow cmd
+  Cmd SSender (SEND msgBody) -> "SEND " <> serializeMsg msgBody
   Cmd SSender PING -> "PING"
   Cmd SBroker (MSG msgId ts msgBody) ->
-    B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts] <> serializeMsg msgBody
+    B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeMsg msgBody]
   Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId]
-  Cmd SBroker (ERR err) -> "ERR " <> B.pack (show err)
-  Cmd SBroker resp -> B.pack $ show resp
+  Cmd SBroker (ERR err) -> "ERR " <> bshow err
+  Cmd SBroker resp -> bshow resp
   where
-    serializeMsg msgBody = " " <> B.pack (show $ B.length msgBody) <> "\r\n" <> msgBody
+    serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " "
 
-tPutRaw :: Handle -> RawTransmission -> IO ()
-tPutRaw h (signature, corrId, queueId, command) = do
-  putLn h signature
-  putLn h corrId
-  putLn h queueId
-  putLn h command
-
-tGetRaw :: Handle -> IO RawTransmission
-tGetRaw h = do
-  signature <- getLn h
-  corrId <- getLn h
-  queueId <- getLn h
-  command <- getLn h
-  return (signature, corrId, queueId, command)
-
-tPut :: Handle -> SignedRawTransmission -> IO ()
-tPut h (C.Signature sig, t) = do
-  putLn h $ encode sig
-  putLn h t
+tPut :: THandle -> SignedRawTransmission -> IO (Either TransportError ())
+tPut th (C.Signature sig, t) =
+  tPutEncrypted th $ encode sig <> " " <> t <> " "
 
 serializeTransmission :: Transmission -> ByteString
 serializeTransmission (CorrId corrId, queueId, command) =
-  B.intercalate "\r\n" [corrId, encode queueId, serializeCommand command]
+  B.intercalate " " [corrId, encode queueId, serializeCommand command]
 
 fromClient :: Cmd -> Either ErrorType Cmd
 fromClient = \case
@@ -213,22 +208,28 @@ fromServer = \case
   cmd@(Cmd SBroker _) -> Right cmd
   _ -> Left PROHIBITED
 
+tGetParse :: THandle -> IO (Either TransportError RawTransmission)
+tGetParse th = (>>= parse transmissionP TransportParsingError) <$> tGetEncrypted th
+
 -- | get client and server transmissions
 -- `fromParty` is used to limit allowed senders - `fromClient` or `fromServer` should be used
-tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> Handle -> m SignedTransmissionOrError
-tGet fromParty h = do
-  (signature, corrId, queueId, command) <- liftIO $ tGetRaw h
-  let decodedTransmission = liftM2 (,corrId,,command) (decode signature) (decode queueId)
-  either (const $ tError corrId) tParseLoadBody decodedTransmission
+tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> THandle -> m SignedTransmissionOrError
+tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate
   where
+    decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError
+    decodeParseValidate = \case
+      Right (signature, corrId, queueId, command) ->
+        let decodedTransmission = liftM2 (,corrId,,command) (decode signature) (decode queueId)
+         in either (const $ tError corrId) tParseValidate decodedTransmission
+      Left _ -> tError ""
+
     tError :: ByteString -> m SignedTransmissionOrError
     tError corrId = return (C.Signature B.empty, (CorrId corrId, B.empty, Left $ SYNTAX errBadTransmission))
 
-    tParseLoadBody :: RawTransmission -> m SignedTransmissionOrError
-    tParseLoadBody t@(sig, corrId, queueId, command) = do
+    tParseValidate :: RawTransmission -> m SignedTransmissionOrError
+    tParseValidate t@(sig, corrId, queueId, command) = do
       let cmd = parseCommand command >>= fromParty >>= tCredentials t
-      fullCmd <- either (return . Left) cmdWithMsgBody cmd
-      return (C.Signature sig, (CorrId corrId, queueId, fullCmd))
+      return (C.Signature sig, (CorrId corrId, queueId, cmd))
 
     tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
     tCredentials (signature, _, queueId, _) cmd = case cmd of
@@ -261,19 +262,3 @@ tGet fromParty h = do
       Cmd SRecipient _
         | B.null signature || B.null queueId -> Left $ SYNTAX errNoCredentials
         | otherwise -> Right cmd
-
-    cmdWithMsgBody :: Cmd -> m (Either ErrorType Cmd)
-    cmdWithMsgBody = \case
-      Cmd SSender (SEND sizeStr) ->
-        Cmd SSender . SEND <$$> getMsgBody sizeStr
-      Cmd SBroker (MSG msgId ts sizeStr) ->
-        Cmd SBroker . MSG msgId ts <$$> getMsgBody sizeStr
-      cmd -> return $ Right cmd
-
-    getMsgBody :: MsgBody -> m (Either ErrorType MsgBody)
-    getMsgBody sizeStr = case readMaybe (B.unpack sizeStr) :: Maybe Int of
-      Just size -> liftIO $ do
-        body <- B.hGet h size
-        s <- getLn h
-        return $ if B.null s then Right body else Left SIZE
-      Nothing -> return $ Left INTERNAL

src/Simplex/Messaging/Server.hs

@@ -15,6 +15,7 @@ module Simplex.Messaging.Server (runSMPServer, randomBytes) where
 
 import Control.Concurrent.STM (stateTVar)
 import Control.Monad
+import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
@@ -59,11 +60,17 @@ runSMPServer cfg@ServerConfig {tcpPort} = do
 
 runClient :: (MonadUnliftIO m, MonadReader Env m) => Handle -> m ()
 runClient h = do
-  liftIO $ putLn h "Welcome to SMP v0.2.0"
+  keyPair <- asks serverKeyPair
+  liftIO (runExceptT $ serverHandshake h keyPair) >>= \case
+    Right th -> runClientTransport th
+    Left _ -> pure ()
+
+runClientTransport :: (MonadUnliftIO m, MonadReader Env m) => THandle -> m ()
+runClientTransport th = do
   q <- asks $ tbqSize . config
   c <- atomically $ newClient q
   s <- asks server
-  raceAny_ [send h c, client c s, receive h c]
+  raceAny_ [send th c, client c s, receive th c]
     `finally` cancelSubscribers c
 
 cancelSubscribers :: MonadUnliftIO m => Client -> m ()
@@ -75,7 +82,7 @@ cancelSub = \case
   Sub {subThread = SubThread t} -> killThread t
   _ -> return ()
 
-receive :: (MonadUnliftIO m, MonadReader Env m) => Handle -> Client -> m ()
+receive :: (MonadUnliftIO m, MonadReader Env m) => THandle -> Client -> m ()
 receive h Client {rcvQ} = forever $ do
   (signature, (corrId, queueId, cmdOrError)) <- tGet fromClient h
   t <- case cmdOrError of
@@ -83,7 +90,7 @@ receive h Client {rcvQ} = forever $ do
     Right cmd -> verifyTransmission (signature, (corrId, queueId, cmd))
   atomically $ writeTBQueue rcvQ t
 
-send :: MonadUnliftIO m => Handle -> Client -> m ()
+send :: MonadUnliftIO m => THandle -> Client -> m ()
 send h Client {sndQ} = forever $ do
   t <- atomically $ readTBQueue sndQ
   liftIO $ tPut h ("", serializeTransmission t)

src/Simplex/Messaging/Server/Env/STM.hs

@@ -5,11 +5,13 @@ module Simplex.Messaging.Server.Env.STM where
 
 import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
+import qualified Crypto.PubKey.RSA as R
 import Crypto.Random
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Network.Socket (ServiceName)
 import Numeric.Natural
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.QueueStore.STM
@@ -27,7 +29,9 @@ data Env = Env
     server :: Server,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
-    idsDrg :: TVar ChaChaDRG
+    idsDrg :: TVar ChaChaDRG,
+    serverKeyPair :: C.KeyPair
+    -- serverId :: ByteString
   }
 
 data Server = Server
@@ -72,4 +76,24 @@ newEnv config = do
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  return Env {config, server, queueStore, msgStore, idsDrg}
+  -- TODO these keys should be set in the environment, not in the code
+  return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair}
+  where
+    serverKeyPair =
+      ( C.PublicKey
+          { rsaPublicKey =
+              R.PublicKey
+                { public_size = 256,
+                  public_n = 24491401566218566997383105010202223087300892576089255259580984651333137614713737618097624532507176450266480395052797332730303098565954279378701980313049999952643146946493842983667770915603693980339519205455913124235423278419181501399080069195664300809453039371169996023512911587381435574254546266774756319955237750224266282550919563293672568339958353047135257914364920805066749904289452712976534358633568668875150094910205741579097517675339029147403213185924413178887675432745168542469043448659751499651038006514754218441022754807971535895895877162103157702709155894482782232155817331812261258282431796597840952464257,
+                  public_e = 8750208418393523480444709183090020123776537336553019181250117771363000810675051423462439348759073000328325050011503730211252469588880505946970399702607609166796825215104414212088697348613726705621594590369250976359268097976909710311654938358716518878047036682173044667792903503207106314854901036618348367397
+                }
+          },
+        C.PrivateKey
+          { private_size = 256,
+            private_n = 24491401566218566997383105010202223087300892576089255259580984651333137614713737618097624532507176450266480395052797332730303098565954279378701980313049999952643146946493842983667770915603693980339519205455913124235423278419181501399080069195664300809453039371169996023512911587381435574254546266774756319955237750224266282550919563293672568339958353047135257914364920805066749904289452712976534358633568668875150094910205741579097517675339029147403213185924413178887675432745168542469043448659751499651038006514754218441022754807971535895895877162103157702709155894482782232155817331812261258282431796597840952464257,
+            private_d = 7597313014691047671352664508683652467940113991200105893460705315744177757772923044415828427601194535604492873282390112577565179730319668643740113323630387082584239892956534048712048059175569855278723311295064858148623887611800385925820852572241607131360121661598015161261779381845187797044113149447495567589968956065009916550602209418325870594974390014927949966324558614396231902374868077411836997835082564279358230227298823445650053370542685308691044175390251929540772677009245507450972026595993054141350350385685400540681305852935721245601287301749047921282924410369389293829570448007237832101875085500166095784749
+          }
+      )
+
+-- public key hash:
+-- "8Cvd+AYVxLpSsB/glEhVxkKuEzMNBFdAL5yr7p9DGGk="

src/Simplex/Messaging/Transport.hs

@@ -1,21 +1,37 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport where
 
-import Control.Monad.IO.Class
+import Control.Monad.Except
 import Control.Monad.IO.Unlift
-import Control.Monad.Reader
+import Control.Monad.Trans.Except (throwE)
+import Crypto.Cipher.Types (AuthTag)
+import Crypto.Hash (hash)
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import Data.ByteArray (xor)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Set (Set)
 import qualified Data.Set as S
+import Data.Word (Word32)
 import GHC.IO.Exception (IOErrorType (..))
+import GHC.IO.Handle.Internals (ioe_EOF)
 import Network.Socket
+import Network.Transport.Internal (encodeWord32)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Parsers (parse, parseAll)
+import Simplex.Messaging.Util (bshow, liftError)
 import System.IO
 import System.IO.Error
 import UnliftIO.Concurrent
@@ -24,6 +40,8 @@ import qualified UnliftIO.Exception as E
 import qualified UnliftIO.IO as IO
 import UnliftIO.STM
 
+-- * TCP transport
+
 runTCPServer :: MonadUnliftIO m => ServiceName -> (Handle -> m ()) -> m ()
 runTCPServer port server = do
   clients <- newTVarIO S.empty
@@ -96,3 +114,177 @@ getLn h = trim_cr <$> B.hGetLine h
   where
     trim_cr "" = ""
     trim_cr s = if B.last s == '\r' then B.init s else s
+
+-- * Encrypted transport
+
+data SMPVersion = SMPVersion Int Int Int Int
+  deriving (Eq, Ord)
+
+major :: SMPVersion -> (Int, Int)
+major (SMPVersion a b _ _) = (a, b)
+
+currentSMPVersion :: SMPVersion
+currentSMPVersion = SMPVersion 0 2 0 0
+
+serializeSMPVersion :: SMPVersion -> ByteString
+serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d]
+
+smpVersionP :: Parser SMPVersion
+smpVersionP =
+  let ver = A.decimal <* A.char '.'
+   in SMPVersion <$> ver <*> ver <*> ver <*> A.decimal
+
+data THandle = THandle
+  { handle :: Handle,
+    sndKey :: SessionKey,
+    rcvKey :: SessionKey,
+    blockSize :: Int
+  }
+
+data SessionKey = SessionKey
+  { aesKey :: C.Key,
+    baseIV :: C.IV,
+    counter :: TVar Word32
+  }
+
+data HandshakeKeys = HandshakeKeys
+  { sndKey :: SessionKey,
+    rcvKey :: SessionKey
+  }
+
+data TransportError
+  = TransportCryptoError C.CryptoError
+  | TransportParsingError
+  | TransportHandshakeError String
+  deriving (Eq, Show, Exception)
+
+tPutEncrypted :: THandle -> ByteString -> IO (Either TransportError ())
+tPutEncrypted THandle {handle = h, sndKey, blockSize} block =
+  encryptBlock sndKey (blockSize - C.authTagSize) block >>= \case
+    Left e -> return . Left $ TransportCryptoError e
+    Right (authTag, msg) -> Right <$> B.hPut h (C.authTagToBS authTag <> msg)
+
+tGetEncrypted :: THandle -> IO (Either TransportError ByteString)
+tGetEncrypted THandle {handle = h, rcvKey, blockSize} =
+  B.hGet h blockSize >>= decryptBlock rcvKey >>= \case
+    Left e -> pure . Left $ TransportCryptoError e
+    Right "" -> ioe_EOF
+    Right msg -> pure $ Right msg
+
+encryptBlock :: SessionKey -> Int -> ByteString -> IO (Either C.CryptoError (AuthTag, ByteString))
+encryptBlock k@SessionKey {aesKey} size block = do
+  ivBytes <- makeNextIV k
+  runExceptT $ C.encryptAES aesKey ivBytes size block
+
+decryptBlock :: SessionKey -> ByteString -> IO (Either C.CryptoError ByteString)
+decryptBlock k@SessionKey {aesKey} block = do
+  let (authTag, msg') = B.splitAt C.authTagSize block
+  ivBytes <- makeNextIV k
+  runExceptT $ C.decryptAES aesKey ivBytes msg' (C.bsToAuthTag authTag)
+
+makeNextIV :: SessionKey -> IO C.IV
+makeNextIV SessionKey {baseIV, counter} = atomically $ do
+  c <- readTVar counter
+  writeTVar counter $ c + 1
+  pure $ iv c
+  where
+    (start, rest) = B.splitAt 4 $ C.unIV baseIV
+    iv c = C.IV $ (start `xor` encodeWord32 c) <> rest
+
+-- | implements server transport handshake as per /rfcs/2021-01-26-crypto.md#transport-encryption
+-- The numbers in function names refer to the steps in the document
+serverHandshake :: Handle -> C.KeyPair -> ExceptT TransportError IO THandle
+serverHandshake h (k, pk) = do
+  liftIO sendPublicKey_1
+  encryptedKeys <- receiveEncryptedKeys_4
+  HandshakeKeys {sndKey, rcvKey} <- decryptParseKeys_5 encryptedKeys
+  th <- liftIO $ transportHandle h rcvKey sndKey -- keys are swapped here
+  sendWelcome_6 th
+  pure th
+  where
+    sendPublicKey_1 :: IO ()
+    sendPublicKey_1 = putLn h $ C.serializePubKey k
+    receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString
+    receiveEncryptedKeys_4 =
+      liftIO (B.hGet h $ C.publicKeySize k) >>= \case
+        "" -> throwE $ TransportHandshakeError "EOF"
+        ks -> pure ks
+    decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO HandshakeKeys
+    decryptParseKeys_5 encKeys =
+      liftError TransportCryptoError (C.decryptOAEP pk encKeys)
+        >>= liftEither . parseHandshakeKeys
+    sendWelcome_6 :: THandle -> ExceptT TransportError IO ()
+    sendWelcome_6 th = ExceptT . tPutEncrypted th $ serializeSMPVersion currentSMPVersion <> " "
+
+-- | implements client transport handshake as per /rfcs/2021-01-26-crypto.md#transport-encryption
+-- The numbers in function names refer to the steps in the document
+clientHandshake :: Handle -> Maybe C.KeyHash -> ExceptT TransportError IO THandle
+clientHandshake h keyHash = do
+  k <- getPublicKey_1_2
+  keys@HandshakeKeys {sndKey, rcvKey} <- liftIO generateKeys_3
+  sendEncryptedKeys_4 k keys
+  th <- liftIO $ transportHandle h sndKey rcvKey
+  getWelcome_6 th >>= checkVersion
+  pure th
+  where
+    getPublicKey_1_2 :: ExceptT TransportError IO C.PublicKey
+    getPublicKey_1_2 = do
+      s <- liftIO $ getLn h
+      maybe (pure ()) (validateKeyHash_2 s) keyHash
+      liftEither $ parseKey s
+    parseKey :: ByteString -> Either TransportError C.PublicKey
+    parseKey = first TransportHandshakeError . parseAll C.pubKeyP
+    validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO ()
+    validateKeyHash_2 k (C.KeyHash kHash)
+      | hash k == kHash = pure ()
+      | otherwise = throwE $ TransportHandshakeError "wrong key hash"
+    generateKeys_3 :: IO HandshakeKeys
+    generateKeys_3 = HandshakeKeys <$> generateKey <*> generateKey
+    generateKey :: IO SessionKey
+    generateKey = do
+      aesKey <- C.randomAesKey
+      baseIV <- C.randomIV
+      pure SessionKey {aesKey, baseIV, counter = undefined}
+    sendEncryptedKeys_4 :: C.PublicKey -> HandshakeKeys -> ExceptT TransportError IO ()
+    sendEncryptedKeys_4 k keys =
+      liftError TransportCryptoError (C.encryptOAEP k $ serializeHandshakeKeys keys)
+        >>= liftIO . B.hPut h
+    getWelcome_6 :: THandle -> ExceptT TransportError IO SMPVersion
+    getWelcome_6 th = ExceptT $ (>>= parseSMPVersion) <$> tGetEncrypted th
+    parseSMPVersion :: ByteString -> Either TransportError SMPVersion
+    parseSMPVersion = first TransportHandshakeError . A.parseOnly (smpVersionP <* A.space)
+    checkVersion :: SMPVersion -> ExceptT TransportError IO ()
+    checkVersion smpVersion =
+      when (major smpVersion > major currentSMPVersion) . throwE $
+        TransportHandshakeError "SMP server version"
+
+serializeHandshakeKeys :: HandshakeKeys -> ByteString
+serializeHandshakeKeys HandshakeKeys {sndKey, rcvKey} =
+  serializeKey sndKey <> serializeKey rcvKey
+  where
+    serializeKey :: SessionKey -> ByteString
+    serializeKey SessionKey {aesKey, baseIV} = C.unKey aesKey <> C.unIV baseIV
+
+handshakeKeysP :: Parser HandshakeKeys
+handshakeKeysP = HandshakeKeys <$> keyP <*> keyP
+  where
+    keyP :: Parser SessionKey
+    keyP = do
+      aesKey <- C.aesKeyP
+      baseIV <- C.ivP
+      pure SessionKey {aesKey, baseIV, counter = undefined}
+
+parseHandshakeKeys :: ByteString -> Either TransportError HandshakeKeys
+parseHandshakeKeys = parse handshakeKeysP $ TransportHandshakeError "parsing keys"
+
+transportHandle :: Handle -> SessionKey -> SessionKey -> IO THandle
+transportHandle h sk rk = do
+  sndCounter <- newTVarIO 0
+  rcvCounter <- newTVarIO 0
+  pure
+    THandle
+      { handle = h,
+        sndKey = sk {counter = sndCounter},
+        rcvKey = rk {counter = rcvCounter},
+        blockSize = 8192
+      }