diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index b71bed5d4..75c5080ec 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -101,7 +101,7 @@ getConfig opts = do storeLog <- liftIO $ openStoreLog opts ini pure $ makeConfig ini pk storeLog -makeConfig :: IniOpts -> C.FullPrivateKey -> Maybe (StoreLog 'ReadMode) -> ServerConfig +makeConfig :: IniOpts -> C.PrivateKey 'C.RSA -> Maybe (StoreLog 'ReadMode) -> ServerConfig makeConfig IniOpts {serverPort, blockSize, enableWebsockets} pk storeLog = let transports = (serverPort, transport @TCP) : [("80", transport @WS) | enableWebsockets] in serverConfig {serverPrivateKey = pk, storeLog, blockSize, transports} @@ -200,11 +200,11 @@ createIni ServerOpts {enableStoreLog} = do enableWebsockets = True } -readKey :: IniOpts -> ExceptT String IO C.FullPrivateKey +readKey :: IniOpts -> ExceptT String IO (C.PrivateKey 'C.RSA) readKey IniOpts {serverKeyFile} = do fileExists serverKeyFile liftIO (S.readKeyFile serverKeyFile) >>= \case - [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.FullPrivateKey pk + [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.PrivateKeyRSA pk [_] -> err "not RSA key" [] -> err "invalid key file format" _ -> err "more than one key" @@ -212,10 +212,10 @@ readKey IniOpts {serverKeyFile} = do err :: String -> ExceptT String IO b err e = throwE $ e <> ": " <> serverKeyFile -createKey :: IniOpts -> IO C.FullPrivateKey +createKey :: IniOpts -> IO (C.PrivateKey 'C.RSA) createKey IniOpts {serverKeyFile} = do - (_, pk) <- C.generateKeyPair newKeySize - S.writeKeyFile S.TraditionalFormat serverKeyFile [PrivKeyRSA $ C.rsaPrivateKey pk] + (_, pk) <- C.generateKeyPair' newKeySize C.SRSA + S.writeKeyFile S.TraditionalFormat serverKeyFile [C.privateToX509 pk] pure pk fileExists :: FilePath -> ExceptT String IO () @@ -233,8 +233,8 @@ confirm msg = do ok <- getLine when (map toLower ok /= "y") exitFailure -serverKeyHash :: C.FullPrivateKey -> B.ByteString -serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey' +serverKeyHash :: C.PrivateKey 'C.RSA -> B.ByteString +serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey openStoreLog :: ServerOpts -> IniOpts -> IO (Maybe (StoreLog 'ReadMode)) openStoreLog ServerOpts {enableStoreLog = l} IniOpts {enableStoreLog = l', storeLogFile = f} diff --git a/package.yaml b/package.yaml index 828811db9..4ecd6a08c 100644 --- a/package.yaml +++ b/package.yaml @@ -37,7 +37,7 @@ dependencies: - cryptonite >= 0.27 && < 0.30 - direct-sqlite == 2.3.* - directory == 1.3.* - - file-embed == 0.0.14.* + - file-embed >= 0.0.14.0 && <= 0.0.15.0 - filepath == 1.4.* - http-types == 0.12.* - generic-random >= 1.3 && < 1.5 diff --git a/protocol/simplex-uri-request.txt b/protocol/simplex-uri-request.txt new file mode 100644 index 000000000..968757398 --- /dev/null +++ b/protocol/simplex-uri-request.txt @@ -0,0 +1,18 @@ +Scheme name: simplex + +Status: Provisional + +Applications/protocols that use this scheme name: +This scheme is used for connection requests in SimpleX Agent Protocol, +a middle layer protocol for managing bi-directional communication via +redundant unidirectional SimpleX Messaging Protocol queues. + +Contact: Evgeny Poberezkin + +Change controller: Evgeny Poberezkin + +References: +The syntax for connection requests in the latest version of SimpleX Agent Protocol: +https://github.com/simplex-chat/simplexmq/blob/v5/protocol/agent-protocol.md#connection-request +SimpleX Messaging Protocol: +https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md diff --git a/protocol/smp-uri-request.txt b/protocol/smp-uri-request.txt new file mode 100644 index 000000000..ffa3fd263 --- /dev/null +++ b/protocol/smp-uri-request.txt @@ -0,0 +1,16 @@ +Scheme name: smp + +Status: Provisional + +Applications/protocols that use this scheme name: +This scheme is used for URIs of message queues in SimpleX Messaging Protocol, +a client-server protocol for asynchronous distributed unidirectional +message transmission via persistent message queues. + +Contact: Evgeny Poberezkin + +Change controller: Evgeny Poberezkin + +References: +The syntax for message queue URIs in the latest version of SimpleX Messaging Protocol: +https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md#smp-queue-uri diff --git a/simplexmq.cabal b/simplexmq.cabal index 554d17f7b..457169cb6 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -79,7 +79,7 @@ library , cryptonite >=0.27 && <0.30 , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed ==0.0.14.* + , file-embed >=0.0.14.0 && <=0.0.15.0 , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* @@ -125,7 +125,7 @@ executable smp-agent , cryptonite >=0.27 && <0.30 , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed ==0.0.14.* + , file-embed >=0.0.14.0 && <=0.0.15.0 , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* @@ -173,7 +173,7 @@ executable smp-server , cryptostore ==0.2.* , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed ==0.0.14.* + , file-embed >=0.0.14.0 && <=0.0.15.0 , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* @@ -232,7 +232,7 @@ test-suite smp-server-test , cryptonite >=0.27 && <0.30 , direct-sqlite ==2.3.* , directory ==1.3.* - , file-embed ==0.0.14.* + , file-embed >=0.0.14.0 && <=0.0.15.0 , filepath ==1.4.* , generic-random >=1.3 && <1.5 , hspec ==2.7.* diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 68c8586dd..20d39a6e2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -69,7 +69,6 @@ import Data.Composition ((.:), (.:.)) import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (isJust) import qualified Data.Text as T @@ -87,9 +86,9 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (MsgBody, SenderPublicKey) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), currentSMPVersionStr, runTransportServer) -import Simplex.Messaging.Util (bshow, tryError) +import Simplex.Messaging.Util (bshow, tryError, unlessM) import System.Random (randomR) -import UnliftIO.Async (Async, async, race_) +import UnliftIO.Async (async, race_) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -287,7 +286,7 @@ joinConn c connId (CRContact (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do sendInvitation c qUri encryptKey cReq cInfo pure connId' -activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () +activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () activateQueueJoining c connId sq verifyKey retryInterval = activateQueue c connId sq verifyKey retryInterval createReplyQueue where @@ -334,39 +333,30 @@ subscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () subscribeConnection' c connId = withStore (`getConn` connId) >>= \case SomeConn _ (DuplexConnection _ rq sq) -> do - resumeDelivery sq + resumeMsgDelivery c connId sq case status (sq :: SndQueue) of - Confirmed -> withVerifyKey sq $ \verifyKey -> do + Confirmed -> do conf <- withStore (`getAcceptedConfirmation` connId) secureQueue c rq $ senderKey (conf :: AcceptedConfirmation) withStore $ \st -> setRcvQueueStatus st rq Secured - activateSecuredQueue rq sq verifyKey - Secured -> withVerifyKey sq $ activateSecuredQueue rq sq + activateSecuredQueue rq sq + Secured -> activateSecuredQueue rq sq Active -> subscribeQueue c rq connId _ -> throwError $ INTERNAL "unexpected queue status" SomeConn _ (SndConnection _ sq) -> do - resumeDelivery sq + resumeMsgDelivery c connId sq case status (sq :: SndQueue) of - Confirmed -> withVerifyKey sq $ \verifyKey -> - activateQueueJoining c connId sq verifyKey =<< resumeInterval + Confirmed -> activateQueueJoining c connId sq (verifyKey sq) =<< resumeInterval Active -> throwError $ CONN SIMPLEX _ -> throwError $ INTERNAL "unexpected queue status" SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId SomeConn _ (ContactConnection _ rq) -> subscribeQueue c rq connId where - resumeDelivery :: SndQueue -> m () - resumeDelivery SndQueue {server} = do - wasDelivering <- resumeMsgDelivery c connId server - unless wasDelivering $ do - pending <- withStore (`getPendingMsgs` connId) - queuePendingMsgs c connId pending - withVerifyKey :: SndQueue -> (C.PublicKey -> m ()) -> m () - withVerifyKey sq action = - let err = throwError $ INTERNAL "missing signing key public counterpart" - in maybe err action . C.publicKey $ signKey sq - activateSecuredQueue :: RcvQueue -> SndQueue -> C.PublicKey -> m () - activateSecuredQueue rq sq verifyKey = do - activateQueueInitiating c connId sq verifyKey =<< resumeInterval + verifyKey :: SndQueue -> C.APublicVerifyKey + verifyKey = C.publicKey . signKey + activateSecuredQueue :: RcvQueue -> SndQueue -> m () + activateSecuredQueue rq sq = do + activateQueueInitiating c connId sq (verifyKey sq) =<< resumeInterval subscribeQueue c rq connId resumeInterval :: m RetryInterval resumeInterval = do @@ -382,14 +372,10 @@ sendMessage' c connId msg = _ -> throwError $ CONN SIMPLEX where enqueueMessage :: SndQueue -> m AgentMsgId - enqueueMessage SndQueue {server} = do + enqueueMessage sq@SndQueue {server} = do + resumeMsgDelivery c connId sq msgId <- storeSentMsg - wasDelivering <- resumeMsgDelivery c connId server - pending <- - if wasDelivering - then pure [PendingMsg {connId, msgId}] - else withStore (`getPendingMsgs` connId) - queuePendingMsgs c connId pending + queuePendingMsgs c connId server [msgId] pure $ unId msgId where storeSentMsg :: m InternalId @@ -410,42 +396,41 @@ sendMessage' c connId msg = createSndMsg st connId msgData pure internalId -resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SMPServer -> m Bool -resumeMsgDelivery c connId srv = do - void $ resume srv (srvMsgDeliveries c) $ runSrvMsgDelivery c srv - resume connId (connMsgDeliveries c) $ runMsgDelivery c connId srv +resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m () +resumeMsgDelivery c connId SndQueue {server} = do + unlessM srvDelivering $ + async (runSrvMsgDelivery c server) + >>= atomically . modifyTVar (srvMsgDeliveries c) . M.insert server + unlessM connQueued $ + withStore (`getPendingMsgs` connId) + >>= queuePendingMsgs c connId server where - resume :: Ord a => a -> TVar (Map a (Async ())) -> m () -> m Bool - resume key actionMap actionProcess = do - isDelivering <- isJust . M.lookup key <$> readTVarIO actionMap - unless isDelivering $ - async actionProcess - >>= atomically . modifyTVar actionMap . M.insert key - pure isDelivering + srvDelivering = isJust . M.lookup server <$> readTVarIO (srvMsgDeliveries c) + connQueued = + atomically $ + isJust + <$> stateTVar + (connMsgsQueued c) + (\m -> (M.lookup connId m, M.insert connId True m)) -queuePendingMsgs :: AgentMonad m => AgentClient -> ConnId -> [PendingMsg] -> m () -queuePendingMsgs c connId pending = - atomically $ getPendingMsgQ connId (connMsgQueues c) >>= forM_ pending . writeTQueue +queuePendingMsgs :: AgentMonad m => AgentClient -> ConnId -> SMPServer -> [InternalId] -> m () +queuePendingMsgs c connId server msgIds = atomically $ do + q <- getPendingMsgQ c server + mapM_ (writeTQueue q . PendingMsg connId) msgIds -getPendingMsgQ :: Ord a => a -> TVar (Map a (TQueue PendingMsg)) -> STM (TQueue PendingMsg) -getPendingMsgQ key queueMap = do - maybe newMsgQueue pure . M.lookup key =<< readTVar queueMap +getPendingMsgQ :: AgentClient -> SMPServer -> STM (TQueue PendingMsg) +getPendingMsgQ c srv = do + maybe newMsgQueue pure . M.lookup srv =<< readTVar (srvMsgQueues c) where newMsgQueue :: STM (TQueue PendingMsg) newMsgQueue = do mq <- newTQueue - modifyTVar queueMap $ M.insert key mq + modifyTVar (srvMsgQueues c) $ M.insert srv mq pure mq -runMsgDelivery :: AgentMonad m => AgentClient -> ConnId -> SMPServer -> m () -runMsgDelivery c connId srv = do - mq <- atomically . getPendingMsgQ connId $ connMsgQueues c - smq <- atomically . getPendingMsgQ srv $ srvMsgQueues c - forever . atomically $ readTQueue mq >>= writeTQueue smq - runSrvMsgDelivery :: forall m. AgentMonad m => AgentClient -> SMPServer -> m () runSrvMsgDelivery c@AgentClient {subQ} srv = do - mq <- atomically . getPendingMsgQ srv $ srvMsgQueues c + mq <- atomically $ getPendingMsgQ c srv ri <- asks $ reconnectInterval . config forever $ do PendingMsg {connId, msgId} <- atomically $ readTQueue mq @@ -649,11 +634,11 @@ confirmQueue c sq senderKey cInfo = do sendConfirmation c sq senderKey cInfo withStore $ \st -> setSndQueueStatus st sq Confirmed -activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () +activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () activateQueueInitiating c connId sq verifyKey retryInterval = activateQueue c connId sq verifyKey retryInterval $ notifyConnected c connId -activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () -> m () +activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () -> m () activateQueue c connId sq verifyKey retryInterval afterActivation = getActivation c connId >>= \case Nothing -> async runActivation >>= addActivation c connId @@ -664,22 +649,27 @@ activateQueue c connId sq verifyKey retryInterval afterActivation = sendHello c sq verifyKey retryInterval withStore $ \st -> setSndQueueStatus st sq Active removeActivation c connId - removeVerificationKey afterActivation - removeVerificationKey :: m () - removeVerificationKey = - let safeSignKey = C.removePublicKey $ signKey sq - in withStore $ \st -> updateSignKey st sq safeSignKey notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m () notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON) newSndQueue :: - (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> EncryptionKey -> m (SndQueue, SenderPublicKey, VerificationKey) -newSndQueue (SMPQueueUri smpServer senderId _) encryptKey = do + (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> C.APublicEncryptKey -> m (SndQueue, SenderPublicKey, C.APublicVerifyKey) +newSndQueue qUri encryptKey = + asks (cmdSignAlg . config) >>= \case + C.SignAlg a -> newSndQueue_ a qUri encryptKey + +newSndQueue_ :: + (C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m, MonadReader Env m) => + C.SAlgorithm a -> + SMPQueueUri -> + C.APublicEncryptKey -> + m (SndQueue, SenderPublicKey, C.APublicVerifyKey) +newSndQueue_ a (SMPQueueUri smpServer senderId _) encryptKey = do size <- asks $ rsaKeySize . config - (senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size - (verifyKey, signKey) <- liftIO $ C.generateKeyPair size + (senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a + (verifyKey, signKey) <- liftIO $ C.generateSignatureKeyPair size C.SRSA let sndQueue = SndQueue { server = smpServer, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index e99486c7f..9dcf023eb 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -73,8 +73,7 @@ data AgentClient = AgentClient subscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)), subscrConns :: TVar (Map ConnId SMPServer), activations :: TVar (Map ConnId (Async ())), -- activations of send queues in progress - connMsgQueues :: TVar (Map ConnId (TQueue PendingMsg)), - connMsgDeliveries :: TVar (Map ConnId (Async ())), + connMsgsQueued :: TVar (Map ConnId Bool), srvMsgQueues :: TVar (Map SMPServer (TQueue PendingMsg)), srvMsgDeliveries :: TVar (Map SMPServer (Async ())), reconnections :: TVar [Async ()], @@ -94,14 +93,13 @@ newAgentClient agentEnv = do subscrSrvrs <- newTVar M.empty subscrConns <- newTVar M.empty activations <- newTVar M.empty - connMsgQueues <- newTVar M.empty - connMsgDeliveries <- newTVar M.empty + connMsgsQueued <- newTVar M.empty srvMsgQueues <- newTVar M.empty srvMsgDeliveries <- newTVar M.empty reconnections <- newTVar [] clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1) lock <- newTMVar () - return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, activations, connMsgQueues, connMsgDeliveries, srvMsgQueues, srvMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock} + return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, activations, connMsgsQueued, srvMsgQueues, srvMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock} -- | Agent monad with MonadReader Env and MonadError AgentErrorType type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m) @@ -177,7 +175,6 @@ closeAgentClient c = liftIO $ do closeSMPServerClients c cancelActions $ activations c cancelActions $ reconnections c - cancelActions $ connMsgDeliveries c cancelActions $ srvMsgDeliveries c closeSMPServerClients :: AgentClient -> IO () @@ -227,14 +224,24 @@ smpClientError = \case SMPTransportError e -> BROKER $ TRANSPORT e e -> INTERNAL $ show e -newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri, EncryptionKey) -newRcvQueue c srv = do +newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri, C.APublicEncryptKey) +newRcvQueue c srv = + asks (cmdSignAlg . config) >>= \case + C.SignAlg a -> newRcvQueue_ a c srv + +newRcvQueue_ :: + (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) => + C.SAlgorithm a -> + AgentClient -> + SMPServer -> + m (RcvQueue, SMPQueueUri, C.APublicEncryptKey) +newRcvQueue_ a c srv = do size <- asks $ rsaKeySize . config - (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size + (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a logServer "-->" c srv "" "NEW" (rcvId, sId) <- withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId] - (encryptKey, decryptKey) <- liftIO $ C.generateKeyPair size + (encryptKey, decryptKey) <- liftIO $ C.generateEncryptionKeyPair size C.SRSA let rq = RcvQueue { server = srv, @@ -303,7 +310,7 @@ sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo = mkConfirmation :: SMPClient -> m MsgBody mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey cInfo -sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> RetryInterval -> m () +sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey ri = withLogSMP_ c server sndId "SEND (retrying)" $ \smp -> do msg <- mkHello smp $ AckMode On @@ -323,7 +330,7 @@ sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey ri = agentMessage = HELLO verifyKey ackMode } -sendInvitation :: forall m. AgentMonad m => AgentClient -> SMPQueueUri -> EncryptionKey -> ConnectionRequest 'CMInvitation -> ConnInfo -> m () +sendInvitation :: forall m. AgentMonad m => AgentClient -> SMPQueueUri -> C.APublicEncryptKey -> ConnectionRequest 'CMInvitation -> ConnInfo -> m () sendInvitation c SMPQueueUri {smpServer, senderId} encryptKey cReq connInfo = do withLogSMP_ c smpServer senderId "SEND " $ \smp -> do msg <- mkInvitation smp @@ -371,15 +378,15 @@ encryptAndSign smp SndQueue {encryptKey, signKey} msg = do paddedSize <- asks $ (blockSize smp -) . reservedMsgSize liftError cryptoError $ do enc <- C.encrypt encryptKey paddedSize msg - C.Signature sig <- C.sign signKey enc - pure $ sig <> enc + sig <- C.sign signKey enc + pure $ C.signatureBytes sig <> enc decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString decryptAndVerify RcvQueue {decryptKey, verifyKey} msg = verifyMessage verifyKey msg >>= liftError cryptoError . C.decrypt decryptKey -encryptUnsigned :: AgentMonad m => SMPClient -> EncryptionKey -> ByteString -> m ByteString +encryptUnsigned :: AgentMonad m => SMPClient -> C.APublicEncryptKey -> ByteString -> m ByteString encryptUnsigned smp encryptKey msg = do paddedSize <- asks $ (blockSize smp -) . reservedMsgSize size <- asks $ rsaKeySize . config @@ -388,15 +395,19 @@ encryptUnsigned smp encryptKey msg = do let sig = B.replicate size ' ' pure $ sig <> enc -verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString +verifyMessage :: AgentMonad m => Maybe C.APublicVerifyKey -> ByteString -> m ByteString verifyMessage verifyKey msg = do - size <- asks $ rsaKeySize . config - let (sig, enc) = B.splitAt size msg + sigSize <- asks $ rsaKeySize . config + let (s, enc) = B.splitAt sigSize msg case verifyKey of Nothing -> pure enc - Just k - | C.verify k (C.Signature sig) enc -> pure enc - | otherwise -> throwError $ AGENT A_SIGNATURE + Just k -> + case C.decodeSignature $ B.take (C.signatureSize k) s of + Left _ -> throwError $ AGENT A_SIGNATURE + Right sig -> + if C.verify k sig enc + then pure enc + else throwError $ AGENT A_SIGNATURE cryptoError :: C.CryptoError -> AgentErrorType cryptoError = \case diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 6a063d4dd..1e9b367cd 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -16,6 +16,7 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client +import qualified Simplex.Messaging.Crypto as C import System.Random (StdGen, newStdGen) import UnliftIO.STM @@ -23,6 +24,7 @@ data AgentConfig = AgentConfig { tcpPort :: ServiceName, smpServers :: NonEmpty SMPServer, rsaKeySize :: Int, + cmdSignAlg :: C.SignAlg, connIdBytes :: Int, tbqSize :: Natural, dbFile :: FilePath, @@ -41,6 +43,7 @@ defaultAgentConfig = { tcpPort = "5224", smpServers = undefined, rsaKeySize = 2048 `div` 8, + cmdSignAlg = C.SignAlg C.SEd448, connIdBytes = 12, tbqSize = 16, dbFile = "smp-agent.db", diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 97c19b35a..6251e6f80 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -66,10 +66,6 @@ module Simplex.Messaging.Agent.Protocol MsgIntegrity (..), MsgErrorType (..), QueueStatus (..), - SignatureKey, - VerificationKey, - EncryptionKey, - DecryptionKey, ACorrId, AgentMsgId, @@ -298,7 +294,7 @@ data SMPMessage -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents data AMessage where -- | the first message in the queue to validate it is secured - HELLO :: VerificationKey -> AckMode -> AMessage + HELLO :: C.APublicVerifyKey -> AckMode -> AMessage -- | reply queue information REPLY :: ConnectionRequest CMInvitation -> AMessage -- | agent envelope for the client message @@ -315,7 +311,7 @@ parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE smpMessageP = A.endOfLine *> smpClientMessageP <|> smpConfirmationP smpConfirmationP :: Parser SMPMessage - smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.pubKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine) + smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.strKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine) smpClientMessageP :: Parser SMPMessage smpClientMessageP = @@ -330,7 +326,7 @@ parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE -- | Serialize SMP message. serializeSMPMessage :: SMPMessage -> ByteString serializeSMPMessage = \case - SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializePubKey sKey) "" (serializeBinary cInfo) <> "\n" + SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializeKey sKey) "" (serializeBinary cInfo) <> "\n" SMPMessage {senderMsgId, senderTimestamp, previousMsgHash, agentMessage} -> let header = messageHeader senderMsgId senderTimestamp previousMsgHash body = serializeAgentMessage agentMessage @@ -347,7 +343,7 @@ agentMessageP = <|> "MSG " *> a_msg <|> "INV " *> a_inv where - hello = HELLO <$> C.pubKeyP <*> ackMode + hello = HELLO <$> C.strKeyP <*> ackMode reply = REPLY <$> connReqP' a_msg = A_MSG <$> binaryBodyP <* A.endOfLine a_inv = A_INV <$> connReqP' <* A.space <*> binaryBodyP <* A.endOfLine @@ -363,7 +359,7 @@ smpServerP = SMPServer <$> server <*> optional port <*> optional kHash serializeAgentMessage :: AMessage -> ByteString serializeAgentMessage = \case - HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else "" + HELLO verifyKey ackMode -> "HELLO " <> C.serializeKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else "" REPLY cReq -> "REPLY " <> serializeConnReq' cReq A_MSG body -> "MSG " <> serializeBinary body <> "\n" A_INV cReq cInfo -> B.unwords ["INV", serializeConnReq' cReq, serializeBinary cInfo] <> "\n" @@ -378,8 +374,8 @@ smpQueueUriP :: Parser SMPQueueUri smpQueueUriP = SMPQueueUri <$> smpServerUriP <* "/" <*> base64UriP <* "#" <*> pure reservedServerKey -reservedServerKey :: C.PublicKey -reservedServerKey = C.PublicKey $ R.PublicKey 1 0 0 +reservedServerKey :: C.APublicVerifyKey +reservedServerKey = C.APublicVerifyKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0) serializeConnReq :: AConnectionRequest -> ByteString serializeConnReq (ACR _ cr) = serializeConnReq' cr @@ -400,7 +396,7 @@ serializeConnReq' = \case CMContact -> "contact" queryStr = renderSimpleQuery True [("smp", queues), ("e2e", key)] queues = B.intercalate "," . map serializeSMPQueueUri $ L.toList crSmpQueues - key = C.serializePubKeyUri crEncryptKey + key = C.serializeKeyUri crEncryptKey connReqP' :: forall m. ConnectionModeI m => Parser (ConnectionRequest m) connReqP' = do @@ -415,7 +411,7 @@ connReqP = do crMode <- "/" *> mode <* "#/?" query <- parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n') crSmpQueues <- paramP "smp" smpQueues query - crEncryptKey <- paramP "e2e" C.pubKeyUriP query + crEncryptKey <- paramP "e2e" C.strKeyUriP query let cReq = ConnReqData {crScheme, crSmpQueues, crEncryptKey} pure $ case crMode of CMInvitation -> ACR SCMInvitation $ CRInvitation cReq @@ -502,7 +498,7 @@ newtype AckMode = AckMode OnOff deriving (Eq, Show) data SMPQueueUri = SMPQueueUri { smpServer :: SMPServer, senderId :: SMP.SenderId, - serverVerifyKey :: VerificationKey + serverVerifyKey :: C.APublicVerifyKey } deriving (Eq, Show) @@ -526,7 +522,7 @@ deriving instance Show AConnectionRequest data ConnReqData = ConnReqData { crScheme :: ConnReqScheme, crSmpQueues :: L.NonEmpty SMPQueueUri, - crEncryptKey :: EncryptionKey + crEncryptKey :: C.APublicEncryptKey } deriving (Eq, Show) @@ -536,18 +532,6 @@ data ConnReqScheme = CRSSimplex | CRSAppServer HostName (Maybe ServiceName) simplexChat :: ConnReqScheme simplexChat = CRSAppServer "simplex.chat" Nothing --- | Public key used to E2E encrypt SMP messages. -type EncryptionKey = C.PublicKey - --- | Private key used to E2E decrypt SMP messages. -type DecryptionKey = C.SafePrivateKey - --- | Private key used to sign SMP commands -type SignatureKey = C.APrivateKey - --- | Public key used by SMP server to authorize (verify) SMP commands. -type VerificationKey = C.PublicKey - data QueueDirection = SND | RCV deriving (Show) -- | SMP queue status. @@ -638,7 +622,7 @@ data SMPAgentError A_PROHIBITED | -- | cannot RSA/AES-decrypt or parse decrypted header A_ENCRYPTION - | -- | invalid RSA signature + | -- | invalid signature A_SIGNATURE deriving (Eq, Generic, Read, Show, Exception) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 4c14c5fe5..2fd664ee4 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -18,6 +18,7 @@ import Data.Kind (Type) import Data.Time (UTCTime) import Data.Type.Equality import Simplex.Messaging.Agent.Protocol +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol ( MsgBody, MsgId, @@ -41,9 +42,8 @@ class Monad m => MonadAgentStore s m where upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m () upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m () setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m () - setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m () + setRcvQueueActive :: s -> RcvQueue -> C.APublicVerifyKey -> m () setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m () - updateSignKey :: s -> SndQueue -> SignatureKey -> m () -- Confirmations createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId @@ -64,7 +64,7 @@ class Monad m => MonadAgentStore s m where createSndMsg :: s -> ConnId -> SndMsgData -> m () updateSndMsgStatus :: s -> ConnId -> InternalId -> SndMsgStatus -> m () getPendingMsgData :: s -> ConnId -> InternalId -> m (SndQueue, MsgBody) - getPendingMsgs :: s -> ConnId -> m [PendingMsg] + getPendingMsgs :: s -> ConnId -> m [InternalId] getMsg :: s -> ConnId -> InternalId -> m Msg checkRcvMsg :: s -> ConnId -> InternalId -> m () updateRcvMsgAck :: s -> ConnId -> InternalId -> m () @@ -77,8 +77,8 @@ data RcvQueue = RcvQueue rcvId :: SMP.RecipientId, rcvPrivateKey :: RecipientPrivateKey, sndId :: Maybe SMP.SenderId, - decryptKey :: DecryptionKey, - verifyKey :: Maybe VerificationKey, + decryptKey :: C.APrivateDecryptKey, + verifyKey :: Maybe C.APublicVerifyKey, status :: QueueStatus } deriving (Eq, Show) @@ -88,8 +88,8 @@ data SndQueue = SndQueue { server :: SMPServer, sndId :: SMP.SenderId, sndPrivateKey :: SenderPrivateKey, - encryptKey :: EncryptionKey, - signKey :: SignatureKey, + encryptKey :: C.APublicEncryptKey, + signKey :: C.APrivateSignKey, status :: QueueStatus } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 75158b0c5..adecc4add 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -52,6 +52,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Parsers (blobFieldParser) import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP @@ -249,7 +250,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto |] [":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId] - setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m () + setRcvQueueActive :: SQLiteStore -> RcvQueue -> C.APublicVerifyKey -> m () setRcvQueueActive st RcvQueue {rcvId, server = SMPServer {host, port}} verifyKey = -- ? throw error if queue does not exist? liftIO . withTransaction st $ \db -> @@ -280,18 +281,6 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto |] [":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId] - updateSignKey :: SQLiteStore -> SndQueue -> SignatureKey -> m () - updateSignKey st SndQueue {sndId, server = SMPServer {host, port}} signatureKey = - liftIO . withTransaction st $ \db -> - DB.executeNamed - db - [sql| - UPDATE snd_queues - SET sign_key = :sign_key - WHERE host = :host AND port = :port AND snd_id = :snd_id; - |] - [":sign_key" := signatureKey, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId] - createConfirmation :: SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId createConfirmation st gVar NewConfirmation {connId, senderKey, senderConnInfo} = liftIOEither . withTransaction st $ \db -> @@ -485,10 +474,10 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto sndQueue :: Maybe SndQueue -> Either StoreError SndQueue sndQueue = maybe (Left SEConnNotFound) Right - getPendingMsgs :: SQLiteStore -> ConnId -> m [PendingMsg] + getPendingMsgs :: SQLiteStore -> ConnId -> m [InternalId] getPendingMsgs st connId = liftIO . withTransaction st $ \db -> - map (PendingMsg connId . fromOnly) + map fromOnly <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_alias = ? AND snd_status = ?" (connId, SndMsgCreated) getMsg :: SQLiteStore -> ConnId -> InternalId -> m Msg diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 87b340aae..0dc0ac929 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -30,7 +30,9 @@ module Simplex.Messaging.Client -- * SMP protocol command functions createSMPQueue, subscribeSMPQueue, + subscribeSMPQueueNotifications, secureSMPQueue, + enableSMPQueueNotifications, sendSMPMessage, ackSMPMessage, suspendSMPQueue, @@ -80,7 +82,7 @@ data SMPClient = SMPClient tcpTimeout :: Int, clientCorrId :: TVar Natural, sentCommands :: TVar (Map CorrId Request), - sndQ :: TBQueue SignedRawTransmission, + sndQ :: TBQueue SentRawTransmission, rcvQ :: TBQueue SignedTransmissionOrError, msgQ :: TBQueue SMPServerTransmission, blockSize :: Int @@ -263,7 +265,7 @@ createSMPQueue :: createSMPQueue c rpKey rKey = -- TODO add signing this request too - requires changes in the server sendSMPCommand c (Just rpKey) "" (Cmd SRecipient $ NEW rKey) >>= \case - Cmd _ (IDS rId sId) -> return (rId, sId) + Cmd _ (IDS rId sId) -> pure (rId, sId) _ -> throwE SMPUnexpectedResponse -- | Subscribe to the SMP queue. @@ -277,12 +279,27 @@ subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId = lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd) _ -> throwE SMPUnexpectedResponse +-- | Subscribe to the SMP queue notifications. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications +subscribeSMPQueueNotifications :: SMPClient -> NotifierPrivateKey -> NotifierId -> ExceptT SMPClientError IO () +subscribeSMPQueueNotifications = okSMPCommand $ Cmd SNotifier NSUB + -- | Secure the SMP queue by adding a sender public key. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command secureSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO () secureSMPQueue c rpKey rId senderKey = okSMPCommand (Cmd SRecipient $ KEY senderKey) c rpKey rId +-- | Enable notifications for the queue for push notifications server. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command +enableSMPQueueNotifications :: SMPClient -> RecipientPrivateKey -> RecipientId -> NotifierPublicKey -> ExceptT SMPClientError IO NotifierId +enableSMPQueueNotifications c rpKey rId notifierKey = + sendSMPCommand c (Just rpKey) rId (Cmd SRecipient $ NKEY notifierKey) >>= \case + Cmd _ (NID nId) -> pure nId + _ -> throwE SMPUnexpectedResponse + -- | Send SMP message. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message @@ -316,14 +333,14 @@ suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO () deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL -okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand :: Cmd -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case Cmd _ OK -> return () _ -> throwE SMPUnexpectedResponse -- | Send any SMP command ('Cmd' type). -sendSMPCommand :: SMPClient -> Maybe C.SafePrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd +sendSMPCommand :: SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId cmd = do corrId <- lift_ getNextCorrId t <- signTransmission $ serializeTransmission (corrId, qId, cmd) @@ -337,20 +354,20 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId i <- stateTVar clientCorrId $ \i -> (i, i + 1) pure . CorrId $ bshow i - signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission + signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission signTransmission t = case pKey of - Nothing -> return ("", t) + Nothing -> return (Nothing, t) Just pk -> do sig <- liftError SMPSignatureError $ C.sign pk t - return (sig, t) + return (Just sig, t) -- two separate "atomically" needed to avoid blocking - sendRecv :: CorrId -> SignedRawTransmission -> IO Response + sendRecv :: CorrId -> SentRawTransmission -> IO Response sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar where withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a - send :: CorrId -> SignedRawTransmission -> STM (TMVar Response) + send :: CorrId -> SentRawTransmission -> STM (TMVar Response) send corrId t = do r <- newEmptyTMVar modifyTVar sentCommands . M.insert corrId $ Request qId r diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index b858d4c0b..decb0c082 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -1,11 +1,19 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -- | -- Module : Simplex.Messaging.Crypto @@ -19,34 +27,50 @@ -- This module provides cryptography implementation for SMP protocols based on -- . module Simplex.Messaging.Crypto - ( -- * RSA keys - PrivateKey (rsaPrivateKey, publicKey), - SafePrivateKey (..), -- constructor is not exported - FullPrivateKey (..), - APrivateKey (..), + ( -- * Cryptographic keys + Algorithm (..), + SAlgorithm (..), + Alg (..), + SignAlg (..), + PrivateKey (..), PublicKey (..), - SafeKeyPair, - FullKeyPair, + APrivateKey (..), + APublicKey (..), + APrivateSignKey (..), + APublicVerifyKey (..), + APrivateDecryptKey (..), + APublicEncryptKey (..), + CryptoKey (..), + CryptoPrivateKey (..), + KeyPair, KeyHash (..), generateKeyPair, - publicKey', - publicKeySize, - validKeySize, - safePrivateKey, - removePublicKey, + generateKeyPair', + generateSignatureKeyPair, + generateEncryptionKeyPair, + privateToX509, -- * E2E hybrid encryption scheme encrypt, + encrypt', decrypt, + decrypt', -- * RSA OAEP encryption encryptOAEP, decryptOAEP, - -- * RSA PSS signing + -- * sign/verify Signature (..), + ASignature (..), + CryptoSignature (..), + SignatureSize (..), + SignatureAlgorithm, + AlgorithmI (..), sign, verify, + verify', + validSignatureSize, -- * AES256 AEAD-GCM scheme Key (..), @@ -62,15 +86,7 @@ module Simplex.Messaging.Crypto ivP, -- * Encoding of RSA keys - serializePrivKey, - serializePubKey, - serializePubKeyUri, - encodePubKey, publicKeyHash, - privKeyP, - pubKeyP, - pubKeyUriP, - binaryPubKeyP, -- * SHA256 hash sha256Hash, @@ -89,6 +105,10 @@ import qualified Crypto.Error as CE import Crypto.Hash (Digest, SHA256 (..), hash) import Crypto.Number.Generate (generateMax) import Crypto.Number.Prime (findPrimeFrom) +import qualified Crypto.PubKey.Curve25519 as X25519 +import qualified Crypto.PubKey.Curve448 as X448 +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.RSA.OAEP as OAEP import qualified Crypto.PubKey.RSA.PSS as PSS @@ -106,103 +126,535 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Constraint (Dict (..)) +import Data.Kind (Constraint, Type) import Data.String +import Data.Type.Equality import Data.X509 import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) +import GHC.TypeLits (ErrorMessage (..), TypeError) import Network.Transport.Internal (decodeWord32, encodeWord32) import Simplex.Messaging.Parsers (base64P, base64UriP, blobFieldParser, parseAll, parseString) import Simplex.Messaging.Util (liftEitherError, (<$?>)) --- | A newtype of 'Crypto.PubKey.RSA.PublicKey'. -newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show) +-- | Cryptographic algorithms. +data Algorithm = RSA | Ed25519 | Ed448 | X25519 | X448 --- | A newtype of 'Crypto.PubKey.RSA.PrivateKey', with PublicKey removed. --- --- It is not possible to recover PublicKey from SafePrivateKey. --- The constructor of this type is not exported. -newtype SafePrivateKey = SafePrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) +-- | Singleton types for 'Algorithm'. +data SAlgorithm :: Algorithm -> Type where + SRSA :: SAlgorithm RSA + SEd25519 :: SAlgorithm Ed25519 + SEd448 :: SAlgorithm Ed448 + SX25519 :: SAlgorithm X25519 + SX448 :: SAlgorithm X448 --- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (with PublicKey inside). -newtype FullPrivateKey = FullPrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) +deriving instance Eq (SAlgorithm a) --- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (PublicKey may be inside). -newtype APrivateKey = APrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) +deriving instance Show (SAlgorithm a) --- | Type-class used for both private key types: SafePrivateKey and FullPrivateKey. -class PrivateKey k where - -- unwraps 'Crypto.PubKey.RSA.PrivateKey' - rsaPrivateKey :: k -> R.PrivateKey +data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a) - -- equivalent to data type constructor, not exported - _privateKey :: R.PrivateKey -> k +data SignAlg + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + SignAlg (SAlgorithm a) - -- smart constructor removing public key from SafePrivateKey but keeping it in FullPrivateKey - mkPrivateKey :: R.PrivateKey -> k +class AlgorithmI (a :: Algorithm) where sAlgorithm :: SAlgorithm a - -- extracts public key from private key - publicKey :: k -> Maybe PublicKey +instance AlgorithmI RSA where sAlgorithm = SRSA --- | Remove public key exponent from APrivateKey. -removePublicKey :: APrivateKey -> APrivateKey -removePublicKey (APrivateKey R.PrivateKey {private_pub = k, private_d}) = - APrivateKey $ unPrivateKey (safePrivateKey (R.public_size k, R.public_n k, private_d) :: SafePrivateKey) +instance AlgorithmI Ed25519 where sAlgorithm = SEd25519 -instance PrivateKey SafePrivateKey where - rsaPrivateKey = unPrivateKey - _privateKey = SafePrivateKey - mkPrivateKey R.PrivateKey {private_pub = k, private_d} = - safePrivateKey (R.public_size k, R.public_n k, private_d) - publicKey _ = Nothing +instance AlgorithmI Ed448 where sAlgorithm = SEd448 -instance PrivateKey FullPrivateKey where - rsaPrivateKey = unPrivateKey - _privateKey = FullPrivateKey - mkPrivateKey = FullPrivateKey - publicKey = Just . PublicKey . R.private_pub . rsaPrivateKey +instance AlgorithmI X25519 where sAlgorithm = SX25519 -instance PrivateKey APrivateKey where - rsaPrivateKey = unPrivateKey - _privateKey = APrivateKey - mkPrivateKey = APrivateKey - publicKey pk = - let k = R.private_pub $ rsaPrivateKey pk - in if R.public_e k == 0 - then Nothing - else Just $ PublicKey k +instance AlgorithmI X448 where sAlgorithm = SX448 -instance IsString FullPrivateKey where - fromString = parseString $ decode >=> decodePrivKey +instance TestEquality SAlgorithm where + testEquality SRSA SRSA = Just Refl + testEquality SEd25519 SEd25519 = Just Refl + testEquality SEd448 SEd448 = Just Refl + testEquality SX25519 SX25519 = Just Refl + testEquality SX448 SX448 = Just Refl + testEquality _ _ = Nothing -instance IsString PublicKey where - fromString = parseString $ decode >=> decodePubKey +-- | GADT for public keys. +data PublicKey (a :: Algorithm) where + PublicKeyRSA :: R.PublicKey -> PublicKey RSA + PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519 + PublicKeyEd448 :: Ed448.PublicKey -> PublicKey Ed448 + PublicKeyX25519 :: X25519.PublicKey -> PublicKey X25519 + PublicKeyX448 :: X448.PublicKey -> PublicKey X448 -instance ToField SafePrivateKey where toField = toField . encodePrivKey +deriving instance Eq (PublicKey a) -instance ToField APrivateKey where toField = toField . encodePrivKey +deriving instance Show (PublicKey a) -instance ToField PublicKey where toField = toField . encodePubKey +data APublicKey + = forall a. + AlgorithmI a => + APublicKey (SAlgorithm a) (PublicKey a) -instance FromField SafePrivateKey where fromField = blobFieldParser binaryPrivKeyP +instance Eq APublicKey where + APublicKey a k == APublicKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False -instance FromField APrivateKey where fromField = blobFieldParser binaryPrivKeyP +deriving instance Show APublicKey -instance FromField PublicKey where fromField = blobFieldParser binaryPubKeyP +-- | GADT for private keys. +data PrivateKey (a :: Algorithm) where + PrivateKeyRSA :: {privateKeyRSA :: R.PrivateKey} -> PrivateKey RSA + PrivateKeyEd25519 :: Ed25519.SecretKey -> Ed25519.PublicKey -> PrivateKey Ed25519 + PrivateKeyEd448 :: Ed448.SecretKey -> Ed448.PublicKey -> PrivateKey Ed448 + PrivateKeyX25519 :: X25519.SecretKey -> PrivateKey X25519 + PrivateKeyX448 :: X448.SecretKey -> PrivateKey X448 + +deriving instance Eq (PrivateKey a) + +deriving instance Show (PrivateKey a) + +data APrivateKey + = forall a. + AlgorithmI a => + APrivateKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateKey where + APrivateKey a k == APrivateKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateKey + +class AlgorithmPrefix k where + algorithmPrefix :: k -> ByteString + +instance AlgorithmPrefix (SAlgorithm a) where + algorithmPrefix = \case + SRSA -> "rsa" + SEd25519 -> "ed25519" + SEd448 -> "ed448" + SX25519 -> "x25519" + SX448 -> "x448" + +instance AlgorithmI a => AlgorithmPrefix (PublicKey a) where + algorithmPrefix _ = algorithmPrefix $ sAlgorithm @a + +instance AlgorithmI a => AlgorithmPrefix (PrivateKey a) where + algorithmPrefix _ = algorithmPrefix $ sAlgorithm @a + +instance AlgorithmPrefix APublicKey where + algorithmPrefix (APublicKey a _) = algorithmPrefix a + +instance AlgorithmPrefix APrivateKey where + algorithmPrefix (APrivateKey a _) = algorithmPrefix a + +prefixAlgorithm :: ByteString -> Either String Alg +prefixAlgorithm = \case + "rsa" -> Right $ Alg SRSA + "ed25519" -> Right $ Alg SEd25519 + "ed448" -> Right $ Alg SEd448 + "x25519" -> Right $ Alg SX25519 + "x448" -> Right $ Alg SX448 + _ -> Left "unknown algorithm" + +algP :: Parser Alg +algP = prefixAlgorithm <$?> A.takeTill (== ':') + +type family SignatureAlgorithm (a :: Algorithm) :: Constraint where + SignatureAlgorithm RSA = () + SignatureAlgorithm Ed25519 = () + SignatureAlgorithm Ed448 = () + SignatureAlgorithm a = + (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used to sign/verify")) + +signatureAlgorithm :: SAlgorithm a -> Maybe (Dict (SignatureAlgorithm a)) +signatureAlgorithm = \case + SRSA -> Just Dict + SEd25519 -> Just Dict + SEd448 -> Just Dict + _ -> Nothing + +data APrivateSignKey + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + APrivateSignKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateSignKey where + APrivateSignKey a k == APrivateSignKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateSignKey + +data APublicVerifyKey + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + APublicVerifyKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicVerifyKey where + APublicVerifyKey a k == APublicVerifyKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicVerifyKey + +type family EncryptionAlgorithm (a :: Algorithm) :: Constraint where + EncryptionAlgorithm RSA = () + EncryptionAlgorithm a = + (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used to encrypt/decrypt")) + +encryptionAlgorithm :: SAlgorithm a -> Maybe (Dict (EncryptionAlgorithm a)) +encryptionAlgorithm = \case + SRSA -> Just Dict + _ -> Nothing + +data APrivateDecryptKey + = forall a. + (AlgorithmI a, EncryptionAlgorithm a) => + APrivateDecryptKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateDecryptKey where + APrivateDecryptKey a k == APrivateDecryptKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateDecryptKey + +data APublicEncryptKey + = forall a. + (AlgorithmI a, EncryptionAlgorithm a) => + APublicEncryptKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicEncryptKey where + APublicEncryptKey a k == APublicEncryptKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicEncryptKey + +-- | Class for all key types +class CryptoKey k where + keySize :: k -> Int + + validKeySize :: k -> Bool + + -- | base64 X509 key encoding with algorithm prefix + serializeKey :: k -> ByteString + + -- | base64url X509 key encoding with algorithm prefix + serializeKeyUri :: k -> ByteString + + -- | binary X509 key encoding + encodeKey :: k -> ByteString + + -- | base64 X509 (with algorithm prefix) key parser + strKeyP :: Parser k + + -- | base64url X509 (with algorithm prefix) key parser + strKeyUriP :: Parser k + + -- | binary X509 key parser + binaryKeyP :: Parser k + +-- | X509 encoding of any public key. +instance CryptoKey APublicKey where + keySize (APublicKey _ k) = keySize k + validKeySize (APublicKey _ k) = validKeySize k + serializeKey (APublicKey _ k) = serializeKey k + serializeKeyUri (APublicKey _ k) = serializeKeyUri k + encodeKey (APublicKey _ k) = encodeKey k + strKeyP = strPublicKeyP_ base64P + strKeyUriP = strPublicKeyP_ base64UriP + binaryKeyP = decodePubKey <$?> A.takeByteString + +strPublicKeyP_ :: Parser ByteString -> Parser APublicKey +strPublicKeyP_ b64P = do + Alg a <- algP <* A.char ':' + k@(APublicKey a' _) <- decodePubKey <$?> b64P + case testEquality a a' of + Just Refl -> pure k + _ -> fail $ "public key algorithm " <> show a <> " does not match prefix" + +-- | X509 encoding of signature public key. +instance CryptoKey APublicVerifyKey where + keySize (APublicVerifyKey _ k) = keySize k + validKeySize (APublicVerifyKey _ k) = validKeySize k + serializeKey (APublicVerifyKey _ k) = serializeKey k + serializeKeyUri (APublicVerifyKey _ k) = serializeKeyUri k + encodeKey (APublicVerifyKey _ k) = encodeKey k + strKeyP = pubVerifyKey <$?> strKeyP + strKeyUriP = pubVerifyKey <$?> strKeyUriP + binaryKeyP = pubVerifyKey <$?> binaryKeyP + +-- | X509 encoding of encryption public key. +instance CryptoKey APublicEncryptKey where + keySize (APublicEncryptKey _ k) = keySize k + validKeySize (APublicEncryptKey _ k) = validKeySize k + serializeKey (APublicEncryptKey _ k) = serializeKey k + serializeKeyUri (APublicEncryptKey _ k) = serializeKeyUri k + encodeKey (APublicEncryptKey _ k) = encodeKey k + strKeyP = pubEncryptKey <$?> strKeyP + strKeyUriP = pubEncryptKey <$?> strKeyUriP + binaryKeyP = pubEncryptKey <$?> binaryKeyP + +-- | X509 encoding of 'PublicKey'. +instance forall a. AlgorithmI a => CryptoKey (PublicKey a) where + keySize = \case + PublicKeyRSA k -> R.public_size k + PublicKeyEd25519 _ -> Ed25519.publicKeySize + PublicKeyEd448 _ -> Ed448.publicKeySize + PublicKeyX25519 _ -> x25519_size + PublicKeyX448 _ -> x448_size + validKeySize = \case + PublicKeyRSA k -> validRSAKeySize $ R.public_size k + _ -> True + serializeKey k = algorithmPrefix k <> ":" <> encode (encodeKey k) + serializeKeyUri k = algorithmPrefix k <> ":" <> U.encode (encodeKey k) + encodeKey = encodeASNKey . publicToX509 + strKeyP = pubKey' <$?> strKeyP + strKeyUriP = pubKey' <$?> strKeyUriP + binaryKeyP = pubKey' <$?> binaryKeyP + +-- | X509 encoding of any private key. +instance CryptoKey APrivateKey where + keySize (APrivateKey _ k) = keySize k + validKeySize (APrivateKey _ k) = validKeySize k + serializeKey (APrivateKey _ k) = serializeKey k + serializeKeyUri (APrivateKey _ k) = serializeKeyUri k + encodeKey (APrivateKey _ k) = encodeKey k + strKeyP = strPrivateKeyP_ base64P + strKeyUriP = strPrivateKeyP_ base64UriP + binaryKeyP = decodePrivKey <$?> A.takeByteString + +strPrivateKeyP_ :: Parser ByteString -> Parser APrivateKey +strPrivateKeyP_ b64P = do + Alg a <- algP <* A.char ':' + k@(APrivateKey a' _) <- decodePrivKey <$?> b64P + case testEquality a a' of + Just Refl -> pure k + _ -> fail $ "private key algorithm " <> show a <> " does not match prefix" + +-- | X509 encoding of signature private key. +instance CryptoKey APrivateSignKey where + keySize (APrivateSignKey _ k) = keySize k + validKeySize (APrivateSignKey _ k) = validKeySize k + serializeKey (APrivateSignKey _ k) = serializeKey k + serializeKeyUri (APrivateSignKey _ k) = serializeKeyUri k + encodeKey (APrivateSignKey _ k) = encodeKey k + strKeyP = privSignKey <$?> strKeyP + strKeyUriP = privSignKey <$?> strKeyUriP + binaryKeyP = privSignKey <$?> binaryKeyP + +-- | X509 encoding of encryption private key. +instance CryptoKey APrivateDecryptKey where + keySize (APrivateDecryptKey _ k) = keySize k + validKeySize (APrivateDecryptKey _ k) = validKeySize k + serializeKey (APrivateDecryptKey _ k) = serializeKey k + serializeKeyUri (APrivateDecryptKey _ k) = serializeKeyUri k + encodeKey (APrivateDecryptKey _ k) = encodeKey k + strKeyP = privDecryptKey <$?> strKeyP + strKeyUriP = privDecryptKey <$?> strKeyUriP + binaryKeyP = privDecryptKey <$?> binaryKeyP + +-- | X509 encoding of 'PrivateKey'. +instance AlgorithmI a => CryptoKey (PrivateKey a) where + keySize = \case + PrivateKeyRSA k -> rsaPrivateKeySize k + PrivateKeyEd25519 _ _ -> Ed25519.secretKeySize + PrivateKeyEd448 _ _ -> Ed448.secretKeySize + PrivateKeyX25519 _ -> x25519_size + PrivateKeyX448 _ -> x448_size + validKeySize = \case + PrivateKeyRSA k -> validRSAKeySize $ rsaPrivateKeySize k + _ -> True + serializeKey k = algorithmPrefix k <> ":" <> encode (encodeKey k) + serializeKeyUri k = algorithmPrefix k <> ":" <> U.encode (encodeKey k) + encodeKey = encodeASNKey . privateToX509 + strKeyP = privKey' <$?> strKeyP + strKeyUriP = privKey' <$?> strKeyUriP + binaryKeyP = privKey' <$?> binaryKeyP + +type family PublicKeyType pk where + PublicKeyType APrivateKey = APublicKey + PublicKeyType APrivateSignKey = APublicVerifyKey + PublicKeyType APrivateDecryptKey = APublicEncryptKey + PublicKeyType (PrivateKey a) = PublicKey a + +class CryptoPrivateKey pk where publicKey :: pk -> PublicKeyType pk + +instance CryptoPrivateKey APrivateKey where + publicKey (APrivateKey a k) = APublicKey a $ publicKey k + +instance CryptoPrivateKey APrivateSignKey where + publicKey (APrivateSignKey a k) = APublicVerifyKey a $ publicKey k + +instance CryptoPrivateKey APrivateDecryptKey where + publicKey (APrivateDecryptKey a k) = APublicEncryptKey a $ publicKey k + +instance CryptoPrivateKey (PrivateKey a) where + publicKey = \case + PrivateKeyRSA k -> PublicKeyRSA $ R.private_pub k + PrivateKeyEd25519 _ k -> PublicKeyEd25519 k + PrivateKeyEd448 _ k -> PublicKeyEd448 k + PrivateKeyX25519 k -> PublicKeyX25519 $ X25519.toPublic k + PrivateKeyX448 k -> PublicKeyX448 $ X448.toPublic k + +instance AlgorithmI a => IsString (PrivateKey a) where + fromString = parseString $ decode >=> decodePrivKey >=> privKey' + +instance AlgorithmI a => IsString (PublicKey a) where + fromString = parseString $ decode >=> decodePubKey >=> pubKey' -- | Tuple of RSA 'PublicKey' and 'PrivateKey'. -type KeyPair k = (PublicKey, k) +type KeyPair a = (PublicKey a, PrivateKey a) --- | Tuple of RSA 'PublicKey' and 'SafePrivateKey'. -type SafeKeyPair = (PublicKey, SafePrivateKey) +type AKeyPair = (APublicKey, APrivateKey) --- | Tuple of RSA 'PublicKey' and 'FullPrivateKey'. -type FullKeyPair = (PublicKey, FullPrivateKey) +type ASignatureKeyPair = (APublicVerifyKey, APrivateSignKey) --- | RSA signature newtype. -newtype Signature = Signature {unSignature :: ByteString} deriving (Eq, Show) +type AnEncryptionKeyPair = (APublicEncryptKey, APrivateDecryptKey) -instance IsString Signature where - fromString = Signature . fromString +generateKeyPair :: AlgorithmI a => Int -> SAlgorithm a -> IO AKeyPair +generateKeyPair size a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair' size a + +generateSignatureKeyPair :: + (AlgorithmI a, SignatureAlgorithm a) => Int -> SAlgorithm a -> IO ASignatureKeyPair +generateSignatureKeyPair size a = + bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair' size a + +generateEncryptionKeyPair :: + (AlgorithmI a, EncryptionAlgorithm a) => Int -> SAlgorithm a -> IO AnEncryptionKeyPair +generateEncryptionKeyPair size a = + bimap (APublicEncryptKey a) (APrivateDecryptKey a) <$> generateKeyPair' size a + +generateKeyPair' :: Int -> SAlgorithm a -> IO (KeyPair a) +generateKeyPair' size = \case + SRSA -> generateKeyPairRSA size + SEd25519 -> + Ed25519.generateSecretKey >>= \pk -> + let k = Ed25519.toPublic pk + in pure (PublicKeyEd25519 k, PrivateKeyEd25519 pk k) + SEd448 -> + Ed448.generateSecretKey >>= \pk -> + let k = Ed448.toPublic pk + in pure (PublicKeyEd448 k, PrivateKeyEd448 pk k) + SX25519 -> + X25519.generateSecretKey >>= \pk -> + let k = X25519.toPublic pk + in pure (PublicKeyX25519 k, PrivateKeyX25519 pk) + SX448 -> + X448.generateSecretKey >>= \pk -> + let k = X448.toPublic pk + in pure (PublicKeyX448 k, PrivateKeyX448 pk) + +instance ToField APrivateSignKey where toField = toField . encodeKey + +instance ToField APublicVerifyKey where toField = toField . encodeKey + +instance ToField APrivateDecryptKey where toField = toField . encodeKey + +instance ToField APublicEncryptKey where toField = toField . encodeKey + +instance FromField APrivateSignKey where fromField = blobFieldParser binaryKeyP + +instance FromField APublicVerifyKey where fromField = blobFieldParser binaryKeyP + +instance FromField APrivateDecryptKey where fromField = blobFieldParser binaryKeyP + +instance FromField APublicEncryptKey where fromField = blobFieldParser binaryKeyP + +instance IsString (Maybe ASignature) where + fromString = parseString $ decode >=> decodeSignature + +data Signature (a :: Algorithm) where + SignatureRSA :: ByteString -> Signature RSA + SignatureEd25519 :: Ed25519.Signature -> Signature Ed25519 + SignatureEd448 :: Ed448.Signature -> Signature Ed448 + +deriving instance Eq (Signature a) + +deriving instance Show (Signature a) + +data ASignature + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + ASignature (SAlgorithm a) (Signature a) + +instance Eq ASignature where + ASignature a s == ASignature a' s' = case testEquality a a' of + Just Refl -> s == s' + _ -> False + +deriving instance Show ASignature + +class CryptoSignature s where + serializeSignature :: s -> ByteString + serializeSignature = encode . signatureBytes + signatureBytes :: s -> ByteString + decodeSignature :: ByteString -> Either String s + +instance CryptoSignature ASignature where + signatureBytes (ASignature _ sig) = signatureBytes sig + decodeSignature s + | l == Ed25519.signatureSize = + ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s + | l == Ed448.signatureSize = + ASignature SEd448 . SignatureEd448 <$> ed Ed448.signature s + | l == 128 || l == 256 || l == 384 || l == 512 = rsa s + | otherwise = Left "bad signature size" + where + l = B.length s + ed alg = first show . CE.eitherCryptoError . alg + rsa = Right . ASignature SRSA . SignatureRSA + +instance CryptoSignature (Maybe ASignature) where + signatureBytes = maybe "" signatureBytes + decodeSignature s + | B.null s = Right Nothing + | otherwise = Just <$> decodeSignature s + +instance AlgorithmI a => CryptoSignature (Signature a) where + signatureBytes = \case + SignatureRSA s -> s + SignatureEd25519 s -> BA.convert s + SignatureEd448 s -> BA.convert s + decodeSignature s = do + ASignature a sig <- decodeSignature s + case testEquality a $ sAlgorithm @a of + Just Refl -> Right sig + _ -> Left "bad signature algorithm" + +class SignatureSize s where signatureSize :: s -> Int + +instance SignatureSize (Signature a) where + signatureSize = \case + SignatureRSA s -> B.length s + SignatureEd25519 _ -> Ed25519.signatureSize + SignatureEd448 _ -> Ed448.signatureSize + +instance SignatureSize APrivateSignKey where + signatureSize (APrivateSignKey _ k) = signatureSize k + +instance SignatureSize APublicVerifyKey where + signatureSize (APublicVerifyKey _ k) = signatureSize k + +instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where + signatureSize = \case + PrivateKeyRSA k -> rsaPrivateKeySize k + PrivateKeyEd25519 _ _ -> Ed25519.signatureSize + PrivateKeyEd448 _ _ -> Ed448.signatureSize + +instance SignatureAlgorithm a => SignatureSize (PublicKey a) where + signatureSize = \case + PublicKeyRSA k -> R.public_size k + PublicKeyEd25519 _ -> Ed25519.signatureSize + PublicKeyEd448 _ -> Ed448.signatureSize + +rsaPrivateKeySize :: R.PrivateKey -> Int +rsaPrivateKeySize = R.public_size . R.private_pub -- | Various cryptographic or related errors. data CryptoError @@ -212,6 +664,8 @@ data CryptoError RSADecryptError R.Error | -- | RSA PSS signature error RSASignError R.Error + | -- | Unsupported signing algorithm + UnsupportedAlgorithm | -- | AES initialization error AESCipherError CE.CryptoError | -- | IV generation error @@ -233,9 +687,9 @@ aesKeySize = 256 `div` 8 authTagSize :: Int authTagSize = 128 `div` 8 --- | Generate RSA key pair with either SafePrivateKey or FullPrivateKey. -generateKeyPair :: PrivateKey k => Int -> IO (KeyPair k) -generateKeyPair size = loop +-- | Generate RSA key pair. +generateKeyPairRSA :: Int -> IO (KeyPair RSA) +generateKeyPairRSA size = loop where publicExponent = findPrimeFrom . (+ 3) <$> generateMax pubExpRange loop = do @@ -244,24 +698,20 @@ generateKeyPair size = loop d = R.private_d pk if d * d < n then loop - else pure (PublicKey k, mkPrivateKey pk) + else pure (PublicKeyRSA k, PrivateKeyRSA pk) -privateKeySize :: PrivateKey k => k -> Int -privateKeySize = R.public_size . R.private_pub . rsaPrivateKey +x25519_size :: Int +x25519_size = 32 -publicKey' :: FullPrivateKey -> PublicKey -publicKey' = PublicKey . R.private_pub . rsaPrivateKey +x448_size :: Int +x448_size = 448 `quot` 8 -publicKeySize :: PublicKey -> Int -publicKeySize = R.public_size . rsaPublicKey +validRSAKeySize :: Int -> Bool +validRSAKeySize n = n == 128 || n == 256 || n == 384 || n == 512 -validKeySize :: Int -> Bool -validKeySize = \case - 128 -> True - 256 -> True - 384 -> True - 512 -> True - _ -> False +validSignatureSize :: Int -> Bool +validSignatureSize n = + n == Ed25519.signatureSize || n == Ed448.signatureSize || validRSAKeySize n data Header = Header { aesKey :: Key, @@ -287,8 +737,8 @@ instance ToField KeyHash where toField = toField . encode . unKeyHash instance FromField KeyHash where fromField = blobFieldParser $ KeyHash <$> base64P -- | Digest (hash) of binary X509 encoding of RSA public key. -publicKeyHash :: PublicKey -> KeyHash -publicKeyHash = KeyHash . sha256Hash . encodePubKey +publicKeyHash :: PublicKey RSA -> KeyHash +publicKeyHash = KeyHash . sha256Hash . encodeKey -- | SHA256 digest. sha256Hash :: ByteString -> ByteString @@ -319,28 +769,36 @@ parseHeader = first CryptoHeaderError . parseAll headerP -- * E2E hybrid encryption scheme --- | E2E encrypt SMP agent messages. +-- | Legacy hybrid E2E encryption of SMP agent messages (RSA-OAEP/AES-256-GCM-SHA256). -- -- https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption -encrypt :: PublicKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString -encrypt k paddedSize msg = do +encrypt' :: PublicKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString +encrypt' k@(PublicKeyRSA _) paddedSize msg = do 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' +encrypt' _ _ _ = throwE UnsupportedAlgorithm --- | E2E decrypt SMP agent messages. +-- | Legacy hybrid E2E decryption of SMP agent messages (RSA-OAEP/AES-256-GCM-SHA256). -- -- https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption -decrypt :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString -decrypt pk msg'' = do - let (encHeader, msg') = B.splitAt (privateKeySize pk) msg'' +decrypt' :: PrivateKey a -> ByteString -> ExceptT CryptoError IO ByteString +decrypt' pk@(PrivateKeyRSA _) msg'' = do + let (encHeader, msg') = B.splitAt (keySize 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 +decrypt' _ _ = throwE UnsupportedAlgorithm + +encrypt :: APublicEncryptKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString +encrypt (APublicEncryptKey _ k) = encrypt' k + +decrypt :: APrivateDecryptKey -> ByteString -> ExceptT CryptoError IO ByteString +decrypt (APrivateDecryptKey _ pk) = decrypt' pk -- | AEAD-GCM encryption. -- @@ -405,112 +863,115 @@ oaepParams = OAEP.defaultOAEPParams SHA256 -- | RSA OAEP encryption. -- -- Used as part of hybrid E2E encryption scheme and for SMP transport handshake. -encryptOAEP :: PublicKey -> ByteString -> ExceptT CryptoError IO ByteString -encryptOAEP (PublicKey k) aesKey = +encryptOAEP :: PublicKey RSA -> ByteString -> ExceptT CryptoError IO ByteString +encryptOAEP (PublicKeyRSA k) aesKey = liftEitherError RSAEncryptError $ OAEP.encrypt oaepParams k aesKey -- | RSA OAEP decryption. -- -- Used as part of hybrid E2E encryption scheme and for SMP transport handshake. -decryptOAEP :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString -decryptOAEP pk encKey = +decryptOAEP :: PrivateKey RSA -> ByteString -> ExceptT CryptoError IO ByteString +decryptOAEP (PrivateKeyRSA pk) encKey = liftEitherError RSADecryptError $ - OAEP.decryptSafer oaepParams (rsaPrivateKey pk) encKey + OAEP.decryptSafer oaepParams pk encKey pssParams :: PSS.PSSParams SHA256 ByteString ByteString pssParams = PSS.defaultPSSParams SHA256 --- | RSA PSS message signing. +-- | Message signing. -- -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages. -sign :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO Signature -sign pk msg = ExceptT $ bimap RSASignError Signature <$> PSS.signSafer pssParams (rsaPrivateKey pk) msg +sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> ExceptT CryptoError IO (Signature a) +sign' (PrivateKeyRSA pk) msg = ExceptT $ bimap RSASignError SignatureRSA <$> PSS.signSafer pssParams pk msg +sign' (PrivateKeyEd25519 pk k) msg = pure . SignatureEd25519 $ Ed25519.sign pk k msg +sign' (PrivateKeyEd448 pk k) msg = pure . SignatureEd448 $ Ed448.sign pk k msg --- | RSA PSS signature verification. +sign :: APrivateSignKey -> ByteString -> ExceptT CryptoError IO ASignature +sign (APrivateSignKey a k) = fmap (ASignature a) . sign' k + +-- | Signature verification. -- -- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages. -verify :: PublicKey -> Signature -> ByteString -> Bool -verify (PublicKey k) (Signature sig) msg = PSS.verify pssParams k msg sig +verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool +verify' (PublicKeyRSA k) (SignatureRSA sig) msg = PSS.verify pssParams k msg sig +verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig +verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig --- | Base-64 X509 encoding of RSA public key. --- --- Used as part of SMP queue information (out-of-band message). -serializePubKey :: PublicKey -> ByteString -serializePubKey = ("rsa:" <>) . encode . encodePubKey +verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool +verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of + Just Refl -> verify' k sig msg + _ -> False -serializePubKeyUri :: PublicKey -> ByteString -serializePubKeyUri = ("rsa:" <>) . U.encode . encodePubKey +pubVerifyKey :: APublicKey -> Either String APublicVerifyKey +pubVerifyKey (APublicKey a k) = case signatureAlgorithm a of + Just Dict -> Right $ APublicVerifyKey a k + _ -> Left "key does not support signature algorithms" --- | Base-64 PKCS8 encoding of PSA private key. --- --- Not used as part of SMP protocols. -serializePrivKey :: PrivateKey k => k -> ByteString -serializePrivKey = ("rsa:" <>) . encode . encodePrivKey +pubEncryptKey :: APublicKey -> Either String APublicEncryptKey +pubEncryptKey (APublicKey a k) = case encryptionAlgorithm a of + Just Dict -> Right $ APublicEncryptKey a k + _ -> Left "key does not support encryption algorithms" --- Base-64 X509 RSA public key parser. -pubKeyP :: Parser PublicKey -pubKeyP = decodePubKey <$?> ("rsa:" *> base64P) +pubKey' :: forall a. AlgorithmI a => APublicKey -> Either String (PublicKey a) +pubKey' (APublicKey a k) = case testEquality a $ sAlgorithm @a of + Just Refl -> Right k + _ -> Left "bad key algorithm" -pubKeyUriP :: Parser PublicKey -pubKeyUriP = decodePubKey <$?> ("rsa:" *> base64UriP) +privSignKey :: APrivateKey -> Either String APrivateSignKey +privSignKey (APrivateKey a k) = case signatureAlgorithm a of + Just Dict -> Right $ APrivateSignKey a k + _ -> Left "key does not support signature algorithms" --- Binary X509 RSA public key parser. -binaryPubKeyP :: Parser PublicKey -binaryPubKeyP = decodePubKey <$?> A.takeByteString +privDecryptKey :: APrivateKey -> Either String APrivateDecryptKey +privDecryptKey (APrivateKey a k) = case encryptionAlgorithm a of + Just Dict -> Right $ APrivateDecryptKey a k + _ -> Left "key does not support encryption algorithms" --- Base-64 PKCS8 RSA private key parser. -privKeyP :: PrivateKey k => Parser k -privKeyP = decodePrivKey <$?> ("rsa:" *> base64P) +privKey' :: forall a. AlgorithmI a => APrivateKey -> Either String (PrivateKey a) +privKey' (APrivateKey a k) = case testEquality a $ sAlgorithm @a of + Just Refl -> Right k + _ -> Left "bad key algorithm" --- Binary PKCS8 RSA private key parser. -binaryPrivKeyP :: PrivateKey k => Parser k -binaryPrivKeyP = decodePrivKey <$?> A.takeByteString +publicToX509 :: PublicKey a -> PubKey +publicToX509 = \case + PublicKeyRSA k -> PubKeyRSA k + PublicKeyEd25519 k -> PubKeyEd25519 k + PublicKeyEd448 k -> PubKeyEd448 k + PublicKeyX25519 k -> PubKeyX25519 k + PublicKeyX448 k -> PubKeyX448 k --- | Construct 'SafePrivateKey' from three numbers - used internally and in the tests. -safePrivateKey :: (Int, Integer, Integer) -> SafePrivateKey -safePrivateKey = SafePrivateKey . safeRsaPrivateKey +privateToX509 :: PrivateKey a -> PrivKey +privateToX509 = \case + PrivateKeyRSA k -> PrivKeyRSA k + PrivateKeyEd25519 k _ -> PrivKeyEd25519 k + PrivateKeyEd448 k _ -> PrivKeyEd448 k + PrivateKeyX25519 k -> PrivKeyX25519 k + PrivateKeyX448 k -> PrivKeyX448 k -safeRsaPrivateKey :: (Int, Integer, Integer) -> R.PrivateKey -safeRsaPrivateKey (size, n, d) = - R.PrivateKey - { private_pub = - R.PublicKey - { public_size = size, - public_n = n, - public_e = 0 - }, - private_d = d, - private_p = 0, - private_q = 0, - private_dP = 0, - private_dQ = 0, - private_qinv = 0 - } - --- Binary X509 encoding of 'PublicKey'. -encodePubKey :: PublicKey -> ByteString -encodePubKey = encodeKey . PubKeyRSA . rsaPublicKey - --- Binary PKCS8 encoding of 'PrivateKey'. -encodePrivKey :: PrivateKey k => k -> ByteString -encodePrivKey = encodeKey . PrivKeyRSA . rsaPrivateKey - -encodeKey :: ASN1Object a => a -> ByteString -encodeKey k = toStrict . encodeASN1 DER $ toASN1 k [] +encodeASNKey :: ASN1Object a => a -> ByteString +encodeASNKey k = toStrict . encodeASN1 DER $ toASN1 k [] -- Decoding of binary X509 'PublicKey'. -decodePubKey :: ByteString -> Either String PublicKey +decodePubKey :: ByteString -> Either String APublicKey decodePubKey = decodeKey >=> \case - (PubKeyRSA k, []) -> Right $ PublicKey k + (PubKeyRSA k, []) -> Right . APublicKey SRSA $ PublicKeyRSA k + (PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k + (PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k + (PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k + (PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k r -> keyError r -- Decoding of binary PKCS8 'PrivateKey'. -decodePrivKey :: PrivateKey k => ByteString -> Either String k +decodePrivKey :: ByteString -> Either String APrivateKey decodePrivKey = decodeKey >=> \case - (PrivKeyRSA pk, []) -> Right $ mkPrivateKey pk + (PrivKeyRSA pk, []) -> Right . APrivateKey SRSA $ PrivateKeyRSA pk + (PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k + (PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k + (PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 $ PrivateKeyX25519 k + (PrivKeyX448 k, []) -> Right . APrivateKey SX448 $ PrivateKeyX448 k r -> keyError r decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1]) @@ -518,5 +979,5 @@ decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict keyError :: (a, [ASN1]) -> Either String b keyError = \case - (_, []) -> Left "not RSA key" + (_, []) -> Left "unknown key algorithm" _ -> Left "more than one key" diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 85d6e8369..f6d072aa2 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -34,15 +34,19 @@ module Simplex.Messaging.Protocol SignedTransmission, SignedTransmissionOrError, RawTransmission, + SentRawTransmission, SignedRawTransmission, CorrId (..), QueueId, RecipientId, SenderId, + NotifierId, RecipientPrivateKey, RecipientPublicKey, SenderPrivateKey, SenderPublicKey, + NotifierPrivateKey, + NotifierPublicKey, Encoded, MsgId, MsgBody, @@ -73,6 +77,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Kind +import Data.Maybe (isNothing) import Data.String import Data.Time.Clock import Data.Time.ISO8601 @@ -85,7 +90,7 @@ import Simplex.Messaging.Util import Test.QuickCheck (Arbitrary (..)) -- | SMP protocol participants. -data Party = Broker | Recipient | Sender +data Party = Broker | Recipient | Sender | Notifier deriving (Show) -- | Singleton types for SMP protocol participants. @@ -93,6 +98,7 @@ data SParty :: Party -> Type where SBroker :: SParty Broker SRecipient :: SParty Recipient SSender :: SParty Sender + SNotifier :: SParty Notifier deriving instance Show (SParty a) @@ -105,18 +111,21 @@ deriving instance Show Cmd type Transmission = (CorrId, QueueId, Cmd) -- | SMP transmission with signature. -type SignedTransmission = (C.Signature, Transmission) +type SignedTransmission = (Maybe C.ASignature, Transmission) type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd) -- | signed parsed transmission, with parsing error. -type SignedTransmissionOrError = (C.Signature, TransmissionOrError) +type SignedTransmissionOrError = (Maybe C.ASignature, TransmissionOrError) -- | unparsed SMP transmission with signature. type RawTransmission = (ByteString, ByteString, ByteString, ByteString) --- | unparsed SMP transmission with signature. -type SignedRawTransmission = (C.Signature, ByteString) +-- | unparsed sent SMP transmission with signature. +type SignedRawTransmission = (Maybe C.ASignature, ByteString, ByteString, ByteString) + +-- | unparsed sent SMP transmission with signature. +type SentRawTransmission = (Maybe C.ASignature, ByteString) -- | SMP queue ID for the recipient. type RecipientId = QueueId @@ -124,6 +133,9 @@ type RecipientId = QueueId -- | SMP queue ID for the sender. type SenderId = QueueId +-- | SMP queue ID for notifications. +type NotifierId = QueueId + -- | SMP queue ID on the server. type QueueId = Encoded @@ -133,15 +145,20 @@ data Command (a :: Party) where NEW :: RecipientPublicKey -> Command Recipient SUB :: Command Recipient KEY :: SenderPublicKey -> Command Recipient + NKEY :: NotifierPublicKey -> Command Recipient ACK :: Command Recipient OFF :: Command Recipient DEL :: Command Recipient -- SMP sender commands SEND :: MsgBody -> Command Sender PING :: Command Sender + -- SMP notification subscriber commands + NSUB :: Command Notifier -- SMP broker commands (responses, messages, notifications) IDS :: RecipientId -> SenderId -> Command Broker MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker + NID :: NotifierId -> Command Broker + NMSG :: Command Broker END :: Command Broker OK :: Command Broker ERR :: ErrorType -> Command Broker @@ -165,18 +182,24 @@ instance IsString CorrId where -- | Recipient's private key used by the recipient to authorize (sign) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type RecipientPrivateKey = C.SafePrivateKey +type RecipientPrivateKey = C.APrivateSignKey -- | Recipient's public key used by SMP server to verify authorization of SMP commands. -type RecipientPublicKey = C.PublicKey +type RecipientPublicKey = C.APublicVerifyKey -- | Sender's private key used by the recipient to authorize (sign) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type SenderPrivateKey = C.SafePrivateKey +type SenderPrivateKey = C.APrivateSignKey -- | Sender's public key used by SMP server to verify authorization of SMP commands. -type SenderPublicKey = C.PublicKey +type SenderPublicKey = C.APublicVerifyKey + +-- | Private key used by push notifications server to authorize (sign) LSTN command. +type NotifierPrivateKey = C.APrivateSignKey + +-- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server. +type NotifierPublicKey = C.APublicVerifyKey -- | SMP message server ID. type MsgId = Encoded @@ -225,11 +248,11 @@ instance Arbitrary CommandError where arbitrary = genericArbitraryU -- | SMP transmission parser. transmissionP :: Parser RawTransmission transmissionP = do - signature <- segment + sig <- segment corrId <- segment queueId <- segment command <- A.takeByteString - return (signature, corrId, queueId, command) + return (sig, corrId, queueId, command) where segment = A.takeTill (== ' ') <* " " @@ -240,20 +263,26 @@ commandP = <|> "IDS " *> idsResp <|> "SUB" $> Cmd SRecipient SUB <|> "KEY " *> keyCmd + <|> "NKEY " *> nKeyCmd + <|> "NID " *> nIdsResp <|> "ACK" $> Cmd SRecipient ACK <|> "OFF" $> Cmd SRecipient OFF <|> "DEL" $> Cmd SRecipient DEL <|> "SEND " *> sendCmd <|> "PING" $> Cmd SSender PING + <|> "NSUB" $> Cmd SNotifier NSUB <|> "MSG " *> message + <|> "NMSG" $> Cmd SBroker NMSG <|> "END" $> Cmd SBroker END <|> "OK" $> Cmd SBroker OK <|> "ERR " *> serverError <|> "PONG" $> Cmd SBroker PONG where - newCmd = Cmd SRecipient . NEW <$> C.pubKeyP + newCmd = Cmd SRecipient . NEW <$> C.strKeyP idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P) - keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP + nIdsResp = Cmd SBroker . NID <$> base64P + keyCmd = Cmd SRecipient . KEY <$> C.strKeyP + nKeyCmd = Cmd SRecipient . NKEY <$> C.strKeyP sendCmd = do size <- A.decimal <* A.space Cmd SSender . SEND <$> A.take size <* A.space @@ -273,16 +302,25 @@ parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX -- | Serialize SMP command. serializeCommand :: Cmd -> ByteString serializeCommand = \case - Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey - Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey - Cmd SRecipient cmd -> bshow cmd + Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializeKey rKey + Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializeKey sKey + Cmd SRecipient (NKEY nKey) -> "NKEY " <> C.serializeKey nKey + Cmd SRecipient SUB -> "SUB" + Cmd SRecipient ACK -> "ACK" + Cmd SRecipient OFF -> "OFF" + Cmd SRecipient DEL -> "DEL" Cmd SSender (SEND msgBody) -> "SEND " <> serializeMsg msgBody Cmd SSender PING -> "PING" + Cmd SNotifier NSUB -> "NSUB" Cmd SBroker (MSG msgId ts 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 (NID nId) -> "NID " <> encode nId Cmd SBroker (ERR err) -> "ERR " <> serializeErrorType err - Cmd SBroker resp -> bshow resp + Cmd SBroker NMSG -> "NMSG" + Cmd SBroker END -> "END" + Cmd SBroker OK -> "OK" + Cmd SBroker PONG -> "PONG" where serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " " @@ -295,9 +333,9 @@ serializeErrorType :: ErrorType -> ByteString serializeErrorType = bshow -- | Send signed SMP transmission to TCP transport. -tPut :: Transport c => THandle c -> SignedRawTransmission -> IO (Either TransportError ()) -tPut th (C.Signature sig, t) = - tPutEncrypted th $ encode sig <> " " <> t <> " " +tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) +tPut th (sig, t) = + tPutEncrypted th $ C.serializeSignature sig <> " " <> t <> " " -- | Serialize SMP transmission. serializeTransmission :: Transmission -> ByteString @@ -329,28 +367,23 @@ 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) (validSig =<< decode signature) (decode queueId) + Right (sig, corrId, queueId, command) -> + let decodedTransmission = liftM2 (,corrId,,command) (C.decodeSignature =<< decode sig) (decode queueId) in either (const $ tError corrId) tParseValidate decodedTransmission Left _ -> tError "" - validSig :: ByteString -> Either String ByteString - validSig sig - | B.null sig || C.validKeySize (B.length sig) = Right sig - | otherwise = Left "invalid signature size" - tError :: ByteString -> m SignedTransmissionOrError - tError corrId = return (C.Signature "", (CorrId corrId, "", Left BLOCK)) + tError corrId = return (Nothing, (CorrId corrId, "", Left BLOCK)) - tParseValidate :: RawTransmission -> m SignedTransmissionOrError + tParseValidate :: SignedRawTransmission -> m SignedTransmissionOrError tParseValidate t@(sig, corrId, queueId, command) = do let cmd = parseCommand command >>= fromParty >>= tCredentials t - return (C.Signature sig, (CorrId corrId, queueId, cmd)) + return (sig, (CorrId corrId, queueId, cmd)) - tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd - tCredentials (signature, _, queueId, _) cmd = case cmd of + tCredentials :: SignedRawTransmission -> Cmd -> Either ErrorType Cmd + tCredentials (sig, _, queueId, _) cmd = case cmd of -- IDS response must not have queue ID - Cmd SBroker (IDS _ _) -> Right cmd + Cmd SBroker IDS {} -> Right cmd -- ERR response does not always have queue ID Cmd SBroker (ERR _) -> Right cmd -- PONG response must not have queue ID @@ -362,8 +395,8 @@ tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate | B.null queueId -> Left $ CMD NO_QUEUE | otherwise -> Right cmd -- NEW must have signature but NOT queue ID - Cmd SRecipient (NEW _) - | B.null signature -> Left $ CMD NO_AUTH + Cmd SRecipient NEW {} + | isNothing sig -> Left $ CMD NO_AUTH | not (B.null queueId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd -- SEND must have queue ID, signature is not always required @@ -372,9 +405,9 @@ tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate | otherwise -> Right cmd -- PING must not have queue ID or signature Cmd SSender PING - | B.null queueId && B.null signature -> Right cmd + | isNothing sig && B.null queueId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID - Cmd SRecipient _ - | B.null signature || B.null queueId -> Left $ CMD NO_AUTH + Cmd _ _ + | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH | otherwise -> Right cmd diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 8c475f9d1..0f173d111 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -35,7 +35,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import qualified Data.Map.Strict as M +import Data.Maybe (isNothing) import Data.Time.Clock +import Data.Type.Equality import Network.Socket (ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol @@ -72,20 +74,38 @@ runSMPServerBlocking started cfg@ServerConfig {transports} = do smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' () smpServer = do s <- asks server - raceAny_ (serverThread s : map runServer transports) + raceAny_ + ( serverThread s subscribedQ subscribers subscriptions cancelSub : + serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) : + map runServer transports + ) `finally` withLog closeStoreLog runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' () runServer (tcpPort, ATransport t) = runTransportServer started tcpPort (runClient t) - serverThread :: MonadUnliftIO m' => Server -> m' () - serverThread Server {subscribedQ, subscribers} = forever . atomically $ do - (rId, clnt) <- readTBQueue subscribedQ - cs <- readTVar subscribers - case M.lookup rId cs of - Just Client {rcvQ} -> writeTBQueue rcvQ (CorrId B.empty, rId, Cmd SBroker END) - Nothing -> return () - writeTVar subscribers $ M.insert rId clnt cs + serverThread :: + forall m' s. + MonadUnliftIO m' => + Server -> + (Server -> TBQueue (QueueId, Client)) -> + (Server -> TVar (M.Map QueueId Client)) -> + (Client -> TVar (M.Map QueueId s)) -> + (s -> m' ()) -> + m' () + serverThread s subQ subs clientSubs unsub = forever $ do + atomically updateSubscribers >>= mapM_ unsub + where + updateSubscribers :: STM (Maybe s) + updateSubscribers = do + (qId, clnt) <- readTBQueue $ subQ s + serverSubs <- readTVar $ subs s + writeTVar (subs s) $ M.insert qId clnt serverSubs + join <$> mapM (endPreviousSubscriptions qId) (M.lookup qId serverSubs) + endPreviousSubscriptions :: QueueId -> Client -> STM (Maybe s) + endPreviousSubscriptions qId c = do + writeTBQueue (rcvQ c) (CorrId B.empty, qId, Cmd SBroker END) + stateTVar (clientSubs c) $ \ss -> (M.lookup qId ss, M.delete qId ss) runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m () runClient _ h = do @@ -123,103 +143,118 @@ receive h Client {rcvQ} = forever $ do send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m () send h Client {sndQ} = forever $ do t <- atomically $ readTBQueue sndQ - liftIO $ tPut h ("", serializeTransmission t) + liftIO $ tPut h (Nothing, serializeTransmission t) mkResp :: CorrId -> QueueId -> Command 'Broker -> Transmission mkResp corrId queueId command = (corrId, queueId, Cmd SBroker command) verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTransmission -> m Transmission -verifyTransmission (sig, t@(corrId, queueId, cmd)) = do +verifyTransmission (sig_, t@(corrId, queueId, cmd)) = do (corrId,queueId,) <$> case cmd of Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used Cmd SRecipient (NEW k) -> pure $ verifySignature k Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey - Cmd SSender (SEND _) -> verifyCmd SSender $ verifySend sig . senderKey + Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey Cmd SSender PING -> return cmd + Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier where verifyCmd :: SParty p -> (QueueRec -> Cmd) -> m Cmd verifyCmd party f = do st <- asks queueStore q <- atomically $ getQueue st party queueId - pure $ either (const $ dummyVerify authErr) f q - verifySend :: C.Signature -> Maybe SenderPublicKey -> Cmd - verifySend "" = maybe cmd (const authErr) - verifySend _ = maybe authErr verifySignature - verifySignature :: C.PublicKey -> Cmd - verifySignature key = if verify key then cmd else authErr - verify key - | C.publicKeySize key == sigLen = cryptoVerify key - | otherwise = dummyVerify False - cryptoVerify key = C.verify key sig (serializeTransmission t) + pure $ either (const $ dummyVerify_ sig_ authErr) f q + verifyMaybe :: Maybe C.APublicVerifyKey -> Cmd + verifyMaybe (Just k) = verifySignature k + verifyMaybe _ = maybe cmd (const authErr) sig_ + verifySignature :: C.APublicVerifyKey -> Cmd + verifySignature key = case sig_ of + Just s -> if verify key s then cmd else authErr + _ -> authErr + verify :: C.APublicVerifyKey -> C.ASignature -> Bool + verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) = + case (testEquality a a', C.signatureSize k == C.signatureSize s) of + (Just Refl, True) -> cryptoVerify k s + _ -> dummyVerify sig False + cryptoVerify :: C.SignatureAlgorithm a => C.PublicKey a -> C.Signature a -> Bool + cryptoVerify k s = C.verify' k s (serializeTransmission t) + dummyVerify_ :: Maybe C.ASignature -> a -> a + dummyVerify_ = \case + Just s -> dummyVerify s + _ -> id + dummyVerify :: C.ASignature -> a -> a + dummyVerify (C.ASignature _ s) = seq $ cryptoVerify (dummyPublicKey s) s smpErr = Cmd SBroker . ERR authErr = smpErr AUTH - dummyVerify :: a -> a - dummyVerify = seq $ - cryptoVerify $ case sigLen of - 128 -> dummyKey128 - 256 -> dummyKey256 - 384 -> dummyKey384 - 512 -> dummyKey512 - _ -> dummyKey256 - sigLen = B.length $ C.unSignature sig -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes -dummyKey128 :: C.PublicKey +dummyPublicKey :: C.Signature a -> C.PublicKey a +dummyPublicKey = \case + C.SignatureRSA s' -> case B.length s' of + 128 -> dummyKey128 + 256 -> dummyKey256 + 384 -> dummyKey384 + 512 -> dummyKey512 + _ -> dummyKey256 + C.SignatureEd25519 _ -> dummyKeyEd25519 + C.SignatureEd448 _ -> dummyKeyEd448 + +dummyKeyEd25519 :: C.PublicKey 'C.Ed25519 +dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" + +dummyKeyEd448 :: C.PublicKey 'C.Ed448 +dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" + +dummyKey128 :: C.PublicKey 'C.RSA dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw==" -dummyKey256 :: C.PublicKey +dummyKey256 :: C.PublicKey 'C.RSA dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9" -dummyKey384 :: C.PublicKey +dummyKey384 :: C.PublicKey 'C.RSA dummyKey384 = "MIICITANBgkqhkiG9w0BAQEFAAOCAg4AMIICCQKCAYEAthExp77lSFBMB0RedjgKIU+oNH5lMGdMqDCG0E5Ly7X49rFpfDMMN08GDIgvzg9kcwV3ScbPcjUE19wmAShX9f9k3w38KM3wmIBKSiuCREQl0V3xAYp1SYwiAkMNSSwxuIkDEeSOR56WdEcZvqbB4lY9MQlUv70KriPDxZaqKCTKslUezXHQuYPQX6eMnGFK7hxz5Kl5MajV52d+5iXsa8CA+m/e1KVnbelCO+xhN89xG8ALt0CJ9k5Wwo3myLgXi4dmNankCmg8jkh+7y2ywkzxMwH1JydDtV/FLzkbZsbPR2w93TNrTq1RJOuqMyh0VtdBSpxNW/Ft988TkkX2BAWzx82INw7W6/QbHGNtHNB995R4sgeYy8QbEpNGBhQnfQh7yRWygLTVXWKApQzzfCeIoDDWUS7dMv/zXoasAnpDBj+6UhHv3BHrps7kBvRyZQ2d/nUuAqiGd43ljJ++n6vNyFLgZoiV7HLia/FOGMkdt7j92CNmFHxiT6Xl7kRHAoGBAPNoWny2O7LBxzAKMLmQVHBAiKp6RMx+7URvtQDHDHPaZ7F3MvtvmYWwGzund3cQFAaV1EkJoYeI3YRuj6xdXgMyMaP54On++btArb6jUtZuvlC98qE8dEEHQNh+7TsCiMU+ivbeKFxS9A/B7OVedoMnPoJWhatbA9zB/6L1GNPh" -dummyKey512 :: C.PublicKey +dummyKey512 :: C.PublicKey 'C.RSA dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ==" client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () -client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} = +client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server {subscribedQ, ntfSubscribedQ, notifiers} = forever $ atomically (readTBQueue rcvQ) >>= processCommand - >>= atomically . writeTBQueue sndQ + >>= atomically . writeTBQueue sndQ' where processCommand :: Transmission -> m Transmission processCommand (corrId, queueId, cmd) = do st <- asks queueStore case cmd of - Cmd SBroker END -> unsubscribeQueue $> (corrId, queueId, cmd) - Cmd SBroker _ -> return (corrId, queueId, cmd) + Cmd SBroker _ -> pure (corrId, queueId, cmd) Cmd SSender command -> case command of SEND msgBody -> sendMessage st msgBody PING -> return (corrId, queueId, Cmd SBroker PONG) + Cmd SNotifier NSUB -> subscribeNotifications Cmd SRecipient command -> case command of NEW rKey -> createQueue st rKey SUB -> subscribeQueue queueId ACK -> acknowledgeMsg KEY sKey -> secureQueue_ st sKey + NKEY nKey -> addQueueNotifier_ st nKey OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st where createQueue :: QueueStore -> RecipientPublicKey -> m Transmission - createQueue st rKey = - checkKeySize rKey addSubscribe + createQueue st rKey = checkKeySize rKey $ addQueueRetry 3 where - addSubscribe = - addQueueRetry 3 >>= \case - Left e -> return $ ERR e - Right (rId, sId) -> do - withLog (`logCreateById` rId) - subscribeQueue rId $> IDS rId sId - - addQueueRetry :: Int -> m (Either ErrorType (RecipientId, SenderId)) - addQueueRetry 0 = return $ Left INTERNAL + addQueueRetry :: Int -> m (Command 'Broker) + addQueueRetry 0 = pure $ ERR INTERNAL addQueueRetry n = do - ids <- getIds + ids@(rId, sId) <- getIds atomically (addQueue st rKey ids) >>= \case Left DUPLICATE_ -> addQueueRetry $ n - 1 - Left e -> return $ Left e - Right _ -> return $ Right ids + Left e -> pure $ ERR e + Right _ -> do + withLog (`logCreateById` rId) + subscribeQueue rId $> IDS rId sId logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO () logCreateById s rId = @@ -237,10 +272,24 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} = withLog $ \s -> logSecureQueue s queueId sKey atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey - checkKeySize :: Monad m' => C.PublicKey -> m' (Command 'Broker) -> m' Transmission + addQueueNotifier_ :: QueueStore -> NotifierPublicKey -> m Transmission + addQueueNotifier_ st nKey = checkKeySize nKey $ addNotifierRetry 3 + where + addNotifierRetry :: Int -> m (Command 'Broker) + addNotifierRetry 0 = pure $ ERR INTERNAL + addNotifierRetry n = do + nId <- randomId =<< asks (queueIdBytes . config) + atomically (addQueueNotifier st queueId nId nKey) >>= \case + Left DUPLICATE_ -> addNotifierRetry $ n - 1 + Left e -> pure $ ERR e + Right _ -> do + withLog $ \s -> logAddNotifier s queueId nId nKey + pure $ NID nId + + checkKeySize :: Monad m' => C.APublicVerifyKey -> m' (Command 'Broker) -> m' Transmission checkKeySize key action = mkResp corrId queueId - <$> if C.validKeySize $ C.publicKeySize key + <$> if C.validKeySize key then action else pure . ERR $ CMD KEY_SIZE @@ -264,11 +313,13 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} = writeTVar subscriptions $ M.insert rId s subs return s - unsubscribeQueue :: m () - unsubscribeQueue = do - sub <- atomically . stateTVar subscriptions $ - \cs -> (M.lookup queueId cs, M.delete queueId cs) - mapM_ cancelSub sub + subscribeNotifications :: m Transmission + subscribeNotifications = atomically $ do + subs <- readTVar ntfSubscriptions + when (isNothing $ M.lookup queueId subs) $ do + writeTBQueue ntfSubscribedQ (queueId, clnt) + writeTVar ntfSubscriptions $ M.insert queueId () subs + pure ok acknowledgeMsg :: m Transmission acknowledgeMsg = @@ -300,9 +351,20 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} = quota <- asks $ msgQueueQuota . config atomically $ do q <- getMsgQueue ms (recipientId qr) quota - isFull q >>= \case - False -> writeMsg q msg $> ok - True -> pure $ err QUOTA + ifM (isFull q) (pure $ err QUOTA) $ do + trySendNotification + writeMsg q msg + pure ok + where + trySendNotification :: STM () + trySendNotification = + forM_ (notifier qr) $ \(nId, _) -> + mapM_ (writeNtf nId) . M.lookup nId =<< readTVar notifiers + + writeNtf :: NotifierId -> Client -> STM () + writeNtf nId Client {sndQ} = + unlessM (isFullTBQueue sndQ) $ + writeTBQueue sndQ $ mkResp (CorrId B.empty) nId NMSG deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m Transmission deliverMessage tryPeek rId = \case @@ -326,7 +388,7 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} = subscriber :: MsgQueue -> m () subscriber q = atomically $ do msg <- peekMsg q - writeTBQueue sndQ $ mkResp (CorrId B.empty) rId (msgCmd msg) + writeTBQueue sndQ' $ mkResp (CorrId B.empty) rId (msgCmd msg) setSub (\s -> s {subThread = NoSub}) void setDelivered diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 5c397096b..f414c71e3 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -30,7 +30,7 @@ data ServerConfig = ServerConfig msgIdBytes :: Int, storeLog :: Maybe (StoreLog 'ReadMode), blockSize :: Int, - serverPrivateKey :: C.FullPrivateKey + serverPrivateKey :: C.PrivateKey 'C.RSA -- serverId :: ByteString } @@ -40,17 +40,20 @@ data Env = Env queueStore :: QueueStore, msgStore :: STMMsgStore, idsDrg :: TVar ChaChaDRG, - serverKeyPair :: C.FullKeyPair, + serverKeyPair :: C.KeyPair 'C.RSA, storeLog :: Maybe (StoreLog 'WriteMode) } data Server = Server { subscribedQ :: TBQueue (RecipientId, Client), - subscribers :: TVar (Map RecipientId Client) + subscribers :: TVar (Map RecipientId Client), + ntfSubscribedQ :: TBQueue (NotifierId, Client), + notifiers :: TVar (Map NotifierId Client) } data Client = Client { subscriptions :: TVar (Map RecipientId Sub), + ntfSubscriptions :: TVar (Map NotifierId ()), rcvQ :: TBQueue Transmission, sndQ :: TBQueue Transmission } @@ -66,14 +69,17 @@ newServer :: Natural -> STM Server newServer qSize = do subscribedQ <- newTBQueue qSize subscribers <- newTVar M.empty - return Server {subscribedQ, subscribers} + ntfSubscribedQ <- newTBQueue qSize + notifiers <- newTVar M.empty + return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers} newClient :: Natural -> STM Client newClient qSize = do subscriptions <- newTVar M.empty + ntfSubscriptions <- newTVar M.empty rcvQ <- newTBQueue qSize sndQ <- newTBQueue qSize - return Client {subscriptions, rcvQ, sndQ} + return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} newSubscription :: STM Sub newSubscription = do @@ -88,13 +94,23 @@ newEnv config = do idsDrg <- drgNew >>= newTVarIO s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig) let pk = serverPrivateKey config - serverKeyPair = (C.publicKey' pk, pk) + serverKeyPair = (C.publicKey pk, pk) return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'} where restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode) restoreQueues queueStore s = do (queues, s') <- liftIO $ readWriteStoreLog s - atomically $ modifyTVar queueStore $ \d -> d {queues, senders = M.foldr' addSender M.empty queues} + atomically $ + modifyTVar queueStore $ \d -> + d + { queues, + senders = M.foldr' addSender M.empty queues, + notifiers = M.foldr' addNotifier M.empty queues + } pure s' addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId addSender q = M.insert (senderId q) (recipientId q) + addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId + addNotifier q = case notifier q of + Nothing -> id + Just (nId, _) -> M.insert nId (recipientId q) diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 79eb2daee..a59a60446 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -8,10 +8,11 @@ module Simplex.Messaging.Server.QueueStore where import Simplex.Messaging.Protocol data QueueRec = QueueRec - { recipientId :: QueueId, - senderId :: QueueId, + { recipientId :: RecipientId, + senderId :: SenderId, recipientKey :: RecipientPublicKey, senderKey :: Maybe SenderPublicKey, + notifier :: Maybe (NotifierId, NotifierPublicKey), status :: QueueStatus } @@ -21,6 +22,7 @@ class MonadQueueStore s m where addQueue :: s -> RecipientPublicKey -> (RecipientId, SenderId) -> m (Either ErrorType ()) getQueue :: s -> SParty (a :: Party) -> QueueId -> m (Either ErrorType QueueRec) secureQueue :: s -> RecipientId -> SenderPublicKey -> m (Either ErrorType ()) + addQueueNotifier :: s -> RecipientId -> NotifierId -> NotifierPublicKey -> m (Either ErrorType ()) suspendQueue :: s -> RecipientId -> m (Either ErrorType ()) deleteQueue :: s -> RecipientId -> m (Either ErrorType ()) @@ -31,5 +33,6 @@ mkQueueRec recipientKey (recipientId, senderId) = senderId, recipientKey, senderKey = Nothing, + notifier = Nothing, status = QueueActive } diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 86caff78f..a4da5ec10 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -19,13 +19,14 @@ import UnliftIO.STM data QueueStoreData = QueueStoreData { queues :: Map RecipientId QueueRec, - senders :: Map SenderId RecipientId + senders :: Map SenderId RecipientId, + notifiers :: Map NotifierId RecipientId } type QueueStore = TVar QueueStoreData newQueueStore :: STM QueueStore -newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty} +newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty, notifiers = M.empty} instance MonadQueueStore QueueStore STM where addQueue :: QueueStore -> RecipientPublicKey -> (RecipientId, SenderId) -> STM (Either ErrorType ()) @@ -42,22 +43,47 @@ instance MonadQueueStore QueueStore STM where return $ Right () getQueue :: QueueStore -> SParty (p :: Party) -> QueueId -> STM (Either ErrorType QueueRec) - getQueue store SRecipient rId = do - cs <- readTVar store - return $ getRcpQueue cs rId - getQueue store SSender sId = do - cs <- readTVar store - let rId = M.lookup sId $ senders cs - return $ maybe (Left AUTH) (getRcpQueue cs) rId - getQueue _ SBroker _ = - return $ Left INTERNAL + getQueue st party qId = do + cs <- readTVar st + pure $ case party of + SRecipient -> getRcpQueue cs qId + SSender -> getPartyQueue cs senders + SNotifier -> getPartyQueue cs notifiers + SBroker -> Left INTERNAL + where + getPartyQueue :: + QueueStoreData -> + (QueueStoreData -> Map QueueId RecipientId) -> + Either ErrorType QueueRec + getPartyQueue cs recipientIds = + case M.lookup qId $ recipientIds cs of + Just rId -> getRcpQueue cs rId + Nothing -> Left AUTH + secureQueue :: QueueStore -> RecipientId -> SenderPublicKey -> STM (Either ErrorType ()) secureQueue store rId sKey = updateQueues store rId $ \cs c -> case senderKey c of Just _ -> (Left AUTH, cs) _ -> (Right (), cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)}) + addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NotifierPublicKey -> STM (Either ErrorType ()) + addQueueNotifier store rId nId nKey = do + cs@QueueStoreData {queues, notifiers} <- readTVar store + if M.member nId notifiers + then pure $ Left DUPLICATE_ + else case M.lookup rId queues of + Nothing -> pure $ Left AUTH + Just q -> case notifier q of + Just _ -> pure $ Left AUTH + _ -> do + writeTVar store $ + cs + { queues = M.insert rId q {notifier = Just (nId, nKey)} queues, + notifiers = M.insert nId rId notifiers + } + pure $ Right () + suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ()) suspendQueue store rId = updateQueues store rId $ \cs c -> diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 8dd468442..2a0d23929 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -14,6 +14,7 @@ module Simplex.Messaging.Server.StoreLog closeStoreLog, logCreateQueue, logSecureQueue, + logAddNotifier, logDeleteQueue, readWriteStoreLog, ) @@ -50,36 +51,44 @@ data StoreLog (a :: IOMode) where data StoreLogRecord = CreateQueue QueueRec | SecureQueue QueueId SenderPublicKey + | AddNotifier QueueId NotifierId NotifierPublicKey | DeleteQueue QueueId storeLogRecordP :: Parser StoreLogRecord storeLogRecordP = "CREATE " *> createQueueP <|> "SECURE " *> secureQueueP + <|> "NOTIFIER " *> addNotifierP <|> "DELETE " *> (DeleteQueue <$> base64P) where createQueueP = CreateQueue <$> queueRecP - secureQueueP = SecureQueue <$> base64P <* A.space <*> C.pubKeyP + secureQueueP = SecureQueue <$> base64P <* A.space <*> C.strKeyP + addNotifierP = + AddNotifier <$> base64P <* A.space <*> base64P <* A.space <*> C.strKeyP queueRecP = do recipientId <- "rid=" *> base64P <* A.space senderId <- "sid=" *> base64P <* A.space - recipientKey <- "rk=" *> C.pubKeyP <* A.space - senderKey <- "sk=" *> optional C.pubKeyP - pure QueueRec {recipientId, senderId, recipientKey, senderKey, status = QueueActive} + recipientKey <- "rk=" *> C.strKeyP <* A.space + senderKey <- "sk=" *> optional C.strKeyP + notifier <- optional $ (,) <$> (" nid=" *> base64P) <*> (" nk=" *> C.strKeyP) + pure QueueRec {recipientId, senderId, recipientKey, senderKey, notifier, status = QueueActive} serializeStoreLogRecord :: StoreLogRecord -> ByteString serializeStoreLogRecord = \case CreateQueue q -> "CREATE " <> serializeQueue q - SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializePubKey sKey + SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializeKey sKey + AddNotifier rId nId nKey -> B.unwords ["NOTIFIER", encode rId, encode nId, C.serializeKey nKey] DeleteQueue rId -> "DELETE " <> encode rId where - serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey} = + serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey, notifier} = B.unwords [ "rid=" <> encode recipientId, "sid=" <> encode senderId, - "rk=" <> C.serializePubKey recipientKey, - "sk=" <> maybe "" C.serializePubKey senderKey + "rk=" <> C.serializeKey recipientKey, + "sk=" <> maybe "" C.serializeKey senderKey ] + <> maybe "" serializeNotifier notifier + serializeNotifier (nId, nKey) = " nid=" <> encode nId <> " nk=" <> C.serializeKey nKey openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode) openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode @@ -110,6 +119,9 @@ logCreateQueue s = writeStoreLogRecord s . CreateQueue logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SenderPublicKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey +logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NotifierPublicKey -> IO () +logAddNotifier s qId nId nKey = writeStoreLogRecord s $ AddNotifier qId nId nKey + logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO () logDeleteQueue s = writeStoreLogRecord s . DeleteQueue @@ -141,6 +153,7 @@ readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLo procLogRecord m = \case CreateQueue q -> M.insert (recipientId q) q m SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m + AddNotifier qId nId nKey -> M.adjust (\q -> q {notifier = Just (nId, nKey)}) qId m DeleteQueue qId -> M.delete qId m printError :: LogParsingError -> IO () printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 10b470c98..99c869f46 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -128,7 +128,7 @@ data ATransport = forall c. Transport c => ATransport (TProxy c) runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> (c -> m ()) -> m () runTransportServer started port server = do clients <- newTVarIO S.empty - E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do + E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) $ \sock -> forever $ do c <- liftIO $ acceptConnection sock tid <- forkFinally (server c) (const $ liftIO $ closeConnection c) atomically . modifyTVar clients $ S.insert tid @@ -192,7 +192,7 @@ instance Transport TCP where transportName _ = "TCP" getServerConnection = fmap TCP . getSocketHandle getClientConnection = getServerConnection - closeConnection = hClose . tcpHandle + closeConnection (TCP h) = hClose h `E.catch` \(_ :: E.SomeException) -> pure () cGet = B.hGet . tcpHandle cPut = B.hPut . tcpHandle getLn = fmap trimCR . B.hGetLine . tcpHandle @@ -314,7 +314,7 @@ tPutEncrypted :: Transport c => THandle c -> ByteString -> IO (Either TransportE tPutEncrypted THandle {connection = c, sndKey, blockSize} block = encryptBlock sndKey (blockSize - C.authTagSize) block >>= \case Left _ -> pure $ Left TEEncrypt - Right (authTag, msg) -> Right <$> cPut c (C.authTagToBS authTag <> msg) + Right (authTag, msg) -> Right <$> cPut c (msg <> C.authTagToBS authTag) -- | Receive and decrypt block from SMP encrypted transport. tGetEncrypted :: Transport c => THandle c -> IO (Either TransportError ByteString) @@ -331,7 +331,7 @@ encryptBlock k@SessionKey {aesKey} size block = do decryptBlock :: SessionKey -> ByteString -> IO (Either C.CryptoError ByteString) decryptBlock k@SessionKey {aesKey} block = do - let (authTag, msg') = B.splitAt C.authTagSize block + let (msg', authTag) = B.splitAt (B.length block - C.authTagSize) block ivBytes <- makeNextIV k runExceptT $ C.decryptAES aesKey ivBytes msg' (C.bsToAuthTag authTag) @@ -349,7 +349,7 @@ makeNextIV SessionKey {baseIV, counter} = atomically $ do -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -- -- The numbers in function names refer to the steps in the document. -serverHandshake :: forall c. Transport c => c -> Int -> C.FullKeyPair -> ExceptT TransportError IO (THandle c) +serverHandshake :: forall c. Transport c => c -> Int -> C.KeyPair 'C.RSA -> ExceptT TransportError IO (THandle c) serverHandshake c srvBlockSize (k, pk) = do checkValidBlockSize srvBlockSize liftIO sendHeaderAndPublicKey_1 @@ -362,13 +362,13 @@ serverHandshake c srvBlockSize (k, pk) = do where sendHeaderAndPublicKey_1 :: IO () sendHeaderAndPublicKey_1 = do - let sKey = C.encodePubKey k + let sKey = C.encodeKey k header = ServerHeader {blockSize = srvBlockSize, keySize = B.length sKey} cPut c $ binaryServerHeader header cPut c sKey receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString receiveEncryptedKeys_4 = - liftIO (cGet c $ C.publicKeySize k) >>= \case + liftIO (cGet c $ C.keySize k) >>= \case "" -> throwE $ TEHandshake TERMINATED ks -> pure ks decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO ClientHandshake @@ -394,7 +394,7 @@ clientHandshake c blkSize_ keyHash = do getWelcome_6 th >>= checkVersion pure th where - getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey, Int) + getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey 'C.RSA, Int) getHeaderAndPublicKey_1_2 = do header <- liftIO (cGet c serverHeaderSize) ServerHeader {blockSize, keySize} <- liftEither $ parse serverHeaderP (TEHandshake HEADER) header @@ -403,8 +403,8 @@ clientHandshake c blkSize_ keyHash = do maybe (pure ()) (validateKeyHash_2 s) keyHash key <- liftEither $ parseKey s pure (key, blockSize) - parseKey :: ByteString -> Either TransportError C.PublicKey - parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryPubKeyP + parseKey :: ByteString -> Either TransportError (C.PublicKey 'C.RSA) + parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryKeyP validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO () validateKeyHash_2 k (C.KeyHash kHash) | C.sha256Hash k == kHash = pure () @@ -416,7 +416,7 @@ clientHandshake c blkSize_ keyHash = do aesKey <- C.randomAesKey baseIV <- C.randomIV pure SessionKey {aesKey, baseIV, counter = undefined} - sendEncryptedKeys_4 :: C.PublicKey -> ClientHandshake -> ExceptT TransportError IO () + sendEncryptedKeys_4 :: C.PublicKey 'C.RSA -> ClientHandshake -> ExceptT TransportError IO () sendEncryptedKeys_4 k chs = liftError (const $ TEHandshake ENCRYPT) (C.encryptOAEP k $ serializeClientHandshake chs) >>= liftIO . cPut c diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 5bd05c4a9..d558a636a 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -42,6 +43,9 @@ f <$?> m = m >>= either fail pure . f bshow :: Show a => a -> ByteString bshow = B.pack . show +maybeWord :: (a -> ByteString) -> Maybe a -> ByteString +maybeWord f = maybe "" $ B.cons ' ' . f + liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a liftIOEither a = liftIO a >>= liftEither @@ -53,3 +57,9 @@ liftEitherError f a = liftIOEither (first f <$> a) tryError :: MonadError e m => m a -> m (Either e a) tryError action = (Right <$> action) `catchError` (pure . Left) + +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM ba t f = ba >>= \b -> if b then t else f + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM b = ifM b $ pure () diff --git a/stack.yaml b/stack.yaml index 70267dd80..945175a35 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.0 +resolver: lts-18.13 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index cf7842d5b..c9aab3a85 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -33,7 +32,7 @@ agentTests (ATransport t) = do describe "Functional API" $ functionalAPITests (ATransport t) describe "SQLite store" storeTests describe "SMP agent protocol syntax" $ syntaxTests t - describe "Establishing duplex connection" do + describe "Establishing duplex connection" $ do it "should connect via one server and one agent" $ smpAgentTest2_1_1 $ testDuplexConnection t it "should connect via one server and one agent (random IDs)" $ @@ -46,19 +45,19 @@ agentTests (ATransport t) = do smpAgentTest2_2_2 $ testDuplexConnection t it "should connect via 2 servers and 2 agents (random IDs)" $ smpAgentTest2_2_2 $ testDuplexConnRandomIds t - describe "Establishing connections via `contact connection`" do + describe "Establishing connections via `contact connection`" $ do it "should connect via contact connection with one server and 3 agents" $ smpAgentTest3 $ testContactConnection t it "should connect via contact connection with one server and 2 agents (random IDs)" $ smpAgentTest2_2_1 $ testContactConnRandomIds t it "should support rejecting contact request" $ smpAgentTest2_2_1 $ testRejectContactRequest t - describe "Connection subscriptions" do + describe "Connection subscriptions" $ do it "should connect via one server and one agent" $ smpAgentTest3_1_1 $ testSubscription t it "should send notifications to client when server disconnects" $ smpAgentServerTest $ testSubscrNotification t - describe "Message delivery" do + describe "Message delivery" $ do it "should deliver messages after losing server connection and re-connecting" $ smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t it "should deliver pending messages after agent restarting" $ @@ -354,21 +353,21 @@ samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSG syntaxTests :: forall c. Transport c => TProxy c -> Spec syntaxTests t = do it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") - describe "NEW" do - describe "valid" do + describe "NEW" $ do + describe "valid" $ do -- TODO: add tests with defined connection alias it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False - describe "invalid" do + describe "invalid" $ do -- TODO: add tests with defined connection alias it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX") - describe "JOIN" do - describe "valid" do + describe "JOIN" $ 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", "a", "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2Flocalhost%3A5000%2F1234-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH") - describe "invalid" do + ("311", "a", "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2Flocalhost%3A5001%2F1234-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH") + describe "invalid" $ do -- TODO: JOIN is not merged yet - to be added it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX") where diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index a39c54ce1..82d9db2eb 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -3,6 +3,7 @@ module AgentTests.ConnectionRequestTests where +import qualified Crypto.PubKey.RSA as R import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Parsers (parseAll) @@ -36,7 +37,7 @@ connectionRequest = ConnReqData { crScheme = appServer, crSmpQueues = [queue], - crEncryptKey = reservedServerKey + crEncryptKey = C.APublicEncryptKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0) } connectionRequestTests :: Spec diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 725367235..4662accee 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -70,42 +70,42 @@ action `throwsError` e = runExceptT action `shouldReturn` Left e -- TODO add null port tests storeTests :: Spec storeTests = do - withStore2 do + withStore2 $ do describe "stress test" testConcurrentWrites - withStore do - describe "store setup" do + withStore $ do + describe "store setup" $ do testCompiledThreadsafe testForeignKeysEnabled - describe "store methods" do - describe "Queue and Connection management" do - describe "createRcvConn" do + describe "store methods" $ do + describe "Queue and Connection management" $ do + describe "createRcvConn" $ do testCreateRcvConn testCreateRcvConnRandomId testCreateRcvConnDuplicate - describe "createSndConn" do + describe "createSndConn" $ do testCreateSndConn testCreateSndConnRandomID testCreateSndConnDuplicate describe "getAllConnIds" testGetAllConnIds describe "getRcvConn" testGetRcvConn - describe "deleteConn" do + describe "deleteConn" $ do testDeleteRcvConn testDeleteSndConn testDeleteDuplexConn - describe "upgradeRcvConnToDuplex" do + describe "upgradeRcvConnToDuplex" $ do testUpgradeRcvConnToDuplex - describe "upgradeSndConnToDuplex" do + describe "upgradeSndConnToDuplex" $ do testUpgradeSndConnToDuplex - describe "set Queue status" do - describe "setRcvQueueStatus" do + describe "set Queue status" $ do + describe "setRcvQueueStatus" $ do testSetRcvQueueStatus testSetRcvQueueStatusNoQueue - describe "setSndQueueStatus" do + describe "setSndQueueStatus" $ do testSetSndQueueStatus testSetSndQueueStatusNoQueue testSetQueueStatusDuplex - describe "Msg management" do - describe "create Msg" do + describe "Msg management" $ do + describe "create Msg" $ do testCreateRcvMsg testCreateSndMsg testCreateRcvAndSndMsgs @@ -149,14 +149,41 @@ testForeignKeysEnabled = cData1 :: ConnData cData1 = ConnData {connId = "conn1"} +testPrivateSignKey :: C.APrivateSignKey +testPrivateSignKey = C.APrivateSignKey C.SRSA testPrivateKey + +testPrivateDecryptKey :: C.APrivateDecryptKey +testPrivateDecryptKey = C.APrivateDecryptKey C.SRSA testPrivateKey + +testPublicEncryptKey :: C.APublicEncryptKey +testPublicEncryptKey = C.APublicEncryptKey C.SRSA $ C.PublicKeyRSA $ R.PublicKey 1 2 3 + +testPrivateKey :: C.PrivateKey 'C.RSA +testPrivateKey = + C.PrivateKeyRSA + R.PrivateKey + { private_pub = + R.PublicKey + { public_size = 1, + public_n = 2, + public_e = 0 + }, + private_d = 3, + private_p = 0, + private_q = 0, + private_dP = 0, + private_dQ = 0, + private_qinv = 0 + } + rcvQueue1 :: RcvQueue rcvQueue1 = RcvQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, rcvId = "1234", - rcvPrivateKey = C.safePrivateKey (1, 2, 3), + rcvPrivateKey = testPrivateSignKey, sndId = Just "2345", - decryptKey = C.safePrivateKey (1, 2, 3), + decryptKey = testPrivateDecryptKey, verifyKey = Nothing, status = New } @@ -166,9 +193,9 @@ sndQueue1 = SndQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, sndId = "3456", - sndPrivateKey = C.safePrivateKey (1, 2, 3), - encryptKey = C.PublicKey $ R.PublicKey 1 2 3, - signKey = C.APrivateKey $ C.unPrivateKey (C.safePrivateKey (1, 2, 3) :: C.SafePrivateKey), + sndPrivateKey = testPrivateSignKey, + encryptKey = testPublicEncryptKey, + signKey = testPrivateSignKey, status = New } @@ -306,9 +333,9 @@ testUpgradeRcvConnToDuplex = SndQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, sndId = "2345", - sndPrivateKey = C.safePrivateKey (1, 2, 3), - encryptKey = C.PublicKey $ R.PublicKey 1 2 3, - signKey = C.APrivateKey $ C.unPrivateKey (C.safePrivateKey (1, 2, 3) :: C.SafePrivateKey), + sndPrivateKey = testPrivateSignKey, + encryptKey = testPublicEncryptKey, + signKey = testPrivateSignKey, status = New } upgradeRcvConnToDuplex store "conn1" anotherSndQueue @@ -326,9 +353,9 @@ testUpgradeSndConnToDuplex = RcvQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, rcvId = "3456", - rcvPrivateKey = C.safePrivateKey (1, 2, 3), + rcvPrivateKey = testPrivateSignKey, sndId = Just "4567", - decryptKey = C.safePrivateKey (1, 2, 3), + decryptKey = testPrivateDecryptKey, verifyKey = Nothing, status = New } diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 3bd6315ac..f4570bbe4 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -157,7 +156,7 @@ cfg :: AgentConfig cfg = defaultAgentConfig { tcpPort = agentTestPort, - smpServers = L.fromList ["localhost:5000#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="], + smpServers = L.fromList ["localhost:5001#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="], tbqSize = 1, dbFile = testDB, smpCfg = diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 58a5d5163..c080641ae 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} @@ -13,6 +12,7 @@ import Control.Monad.Except (runExceptT) import Control.Monad.IO.Unlift import Crypto.Random import Data.ByteString.Base64 (encode) +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Network.Socket import qualified Simplex.Messaging.Crypto as C @@ -31,12 +31,12 @@ testHost :: HostName testHost = "localhost" testPort :: ServiceName -testPort = "5000" +testPort = "5001" testPort2 :: ServiceName -testPort2 = "5001" +testPort2 = "5002" -testKeyHashStr :: B.ByteString +testKeyHashStr :: ByteString testKeyHashStr = "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8=" testBlockSize :: Maybe Int @@ -140,8 +140,8 @@ runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients [] run 0 hs = test hs run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) -smpServerTest :: forall c. Transport c => TProxy c -> RawTransmission -> IO RawTransmission -smpServerTest _ cmd = runSmpTest $ \(h :: THandle c) -> tPutRaw h cmd >> tGetRaw h +smpServerTest :: forall c. Transport c => TProxy c -> SignedRawTransmission -> IO SignedRawTransmission +smpServerTest _ t = runSmpTest $ \(h :: THandle c) -> tPutRaw h t >> tGetRaw h smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation smpTest _ test' = runSmpTest test' `shouldReturn` () @@ -161,12 +161,18 @@ smpTest3 _ test' = smpTestN 3 _test _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" -tPutRaw :: Transport c => THandle c -> RawTransmission -> IO () +smpTest4 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation +smpTest4 _ test' = smpTestN 4 _test + where + _test [h1, h2, h3, h4] = test' h1 h2 h3 h4 + _test _ = error "expected 4 handles" + +tPutRaw :: Transport c => THandle c -> SignedRawTransmission -> IO () tPutRaw h (sig, corrId, queueId, command) = do let t = B.intercalate " " [corrId, queueId, command] - void $ tPut h (C.Signature sig, t) + void $ tPut h (sig, t) -tGetRaw :: Transport c => THandle c -> IO RawTransmission +tGetRaw :: Transport c => THandle c -> IO SignedRawTransmission tGetRaw h = do - ("", (CorrId corrId, qId, Right cmd)) <- tGet fromServer h - pure ("", corrId, encode qId, serializeCommand cmd) + (Nothing, (CorrId corrId, qId, Right cmd)) <- tGet fromServer h + pure (Nothing, corrId, encode qId, serializeCommand cmd) diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index a3d93093b..5c4a2e6e8 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -31,26 +30,27 @@ rsaKeySize = 2048 `div` 8 serverTests :: ATransport -> Spec serverTests t = do describe "SMP syntax" $ syntaxTests t - describe "SMP queues" do + describe "SMP queues" $ do describe "NEW and KEY commands, SEND messages" $ testCreateSecure t describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t - describe "SMP messages" do + describe "SMP messages" $ do describe "duplex communication over 2 SMP connections" $ testDuplex t describe "switch subscription to another SMP queue" $ testSwitchSub t describe "Store log" $ testWithStoreLog t describe "Timing of AUTH error" $ testTiming t + describe "Message notifications" $ testMessageNotifications t pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command))) -sendRecv :: Transport c => THandle c -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +sendRecv :: Transport c => THandle c -> (Maybe C.ASignature, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError sendRecv h (sgn, corrId, qId, cmd) = tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h -signSendRecv :: Transport c => THandle c -> C.SafePrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +signSendRecv :: Transport c => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError signSendRecv h pk (corrId, qId, cmd) = do let t = B.intercalate " " [corrId, encode qId, cmd] Right sig <- runExceptT $ C.sign pk t - _ <- tPut h (sig, t) + _ <- tPut h (Just sig, t) tGet fromServer h cmdSEND :: ByteString -> ByteString @@ -63,8 +63,8 @@ testCreateSecure :: ATransport -> Spec testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest t $ \h -> do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializeKey rPub) (rId1, "") #== "creates queue" Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ") @@ -80,12 +80,12 @@ testCreateSecure (ATransport t) = Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK") (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - (sPub, sKey) <- C.generateKeyPair rsaKeySize + (sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" - let keyCmd = "KEY " <> C.serializePubKey sPub + let keyCmd = "KEY " <> C.serializeKey sPub Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd) (err2, ERR AUTH) #== "rejects KEY with wrong signature" @@ -115,12 +115,12 @@ testCreateDelete :: ATransport -> Spec testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializeKey rPub) (rId1, "") #== "creates queue" - (sPub, sKey) <- C.generateKeyPair rsaKeySize - Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub) + (sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializeKey sPub) (ok1, OK) #== "secures queue" Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ") @@ -183,22 +183,22 @@ testDuplex :: ATransport -> Spec testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do - (arPub, arKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializePubKey arPub) + (arPub, arKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializeKey arPub) -- aSnd ID is passed to Bob out-of-band - (bsPub, bsKey) <- C.generateKeyPair rsaKeySize - Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializePubKey bsPub) + (bsPub, bsKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializeKey bsPub) -- "key ..." is ad-hoc, different from SMP protocol Resp "" _ (MSG _ _ msg1) <- tGet fromServer alice Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK") ["key", bobKey] <- return $ B.words msg1 - (bobKey, C.serializePubKey bsPub) #== "key received from Bob" + (bobKey, C.serializeKey bsPub) #== "key received from Bob" Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey) - (brPub, brKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializePubKey brPub) + (brPub, brKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializeKey brPub) Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, cmdSEND $ "reply_id " <> encode bSnd) -- "reply_id ..." is ad-hoc, it is not a part of SMP protocol @@ -207,14 +207,14 @@ testDuplex (ATransport t) = ["reply_id", bId] <- return $ B.words msg2 (bId, encode bSnd) #== "reply queue ID received from Bob" - (asPub, asKey) <- C.generateKeyPair rsaKeySize - Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializePubKey asPub) + (asPub, asKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializeKey asPub) -- "key ..." is ad-hoc, different from SMP protocol Resp "" _ (MSG _ _ msg3) <- tGet fromServer bob Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK") ["key", aliceKey] <- return $ B.words msg3 - (aliceKey, C.serializePubKey asPub) #== "key received from Alice" + (aliceKey, C.serializeKey asPub) #== "key received from Alice" Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey) Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 hi alice ") @@ -233,8 +233,8 @@ testSwitchSub :: ATransport -> Spec testSwitchSub (ATransport t) = it "should create simplex connections and switch subscription to another TCP connection" $ smpTest3 t $ \rh1 rh2 sh -> do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializeKey rPub) Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5 test1 ") (ok1, OK) #== "sent test message 1" Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK") @@ -270,16 +270,22 @@ testSwitchSub (ATransport t) = testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) = it "should store simplex queues to log and restore them after server restart" $ do - (sPub1, sKey1) <- C.generateKeyPair rsaKeySize - (sPub2, sKey2) <- C.generateKeyPair rsaKeySize + (sPub1, sKey1) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + (sPub2, sKey2) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + (nPub, nKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA senderId1 <- newTVarIO "" senderId2 <- newTVarIO "" + notifierId <- newTVarIO "" - withSmpServerStoreLogOn at testPort . runTest t $ \h -> do - (sId1, _, _) <- createAndSecureQueue h sPub1 + withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do + (sId1, rId, rKey) <- createAndSecureQueue h sPub1 atomically $ writeTVar senderId1 sId1 + Resp "abcd" _ (NID nId) <- signSendRecv h rKey ("abcd", rId, "NKEY " <> C.serializeKey nPub) + atomically $ writeTVar notifierId nId + Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB") Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") Resp "" _ (MSG _ _ "hello") <- tGet fromServer h + Resp "" _ NMSG <- tGet fromServer h1 (sId2, rId2, rKey2) <- createAndSecureQueue h sPub2 atomically $ writeTVar senderId2 sId2 @@ -289,7 +295,7 @@ testWithStoreLog at@(ATransport t) = Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL") pure () - logSize `shouldReturn` 5 + logSize `shouldReturn` 6 withSmpServerThreadOn at testPort . runTest t $ \h -> do sId1 <- readTVarIO senderId1 @@ -297,10 +303,12 @@ testWithStoreLog at@(ATransport t) = Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") pure () - withSmpServerStoreLogOn at testPort . runTest t $ \h -> do + withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do -- this queue is restored sId1 <- readTVarIO senderId1 + nId <- readTVarIO notifierId Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") + Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB") -- this queue is removed - not restored sId2 <- readTVarIO senderId2 Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ") @@ -309,87 +317,139 @@ testWithStoreLog at@(ATransport t) = logSize `shouldReturn` 1 removeFile testStoreLogFile where - createAndSecureQueue :: Transport c => THandle c -> SenderPublicKey -> IO (SenderId, RecipientId, C.SafePrivateKey) - createAndSecureQueue h sPub = do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) - let keyCmd = "KEY " <> C.serializePubKey sPub - Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd) - (rId', rId) #== "same queue ID" - pure (sId, rId, rKey) - runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () killThread server + runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation + runClient _ test' = testSMPClient test' `shouldReturn` () + logSize :: IO Int logSize = try (length . B.lines <$> B.readFile testStoreLogFile) >>= \case Right l -> pure l Left (_ :: SomeException) -> logSize +createAndSecureQueue :: Transport c => THandle c -> SenderPublicKey -> IO (SenderId, RecipientId, C.APrivateSignKey) +createAndSecureQueue h sPub = do + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializeKey rPub) + let keyCmd = "KEY " <> C.serializeKey sPub + Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd) + (rId', rId) #== "same queue ID" + pure (sId, rId, rKey) + testTiming :: ATransport -> Spec testTiming (ATransport t) = it "should have similar time for auth error, whether queue exists or not, for all key sizes" $ smpTest2 t $ \rh sh -> mapM_ (testSameTiming rh sh) - [ (128, 128, 100), - (128, 256, 25), - (128, 384, 15), - -- (128, 512, 15), - (256, 128, 100), - (256, 256, 25), - (256, 384, 15), - -- (256, 512, 15), - (384, 128, 100), - (384, 256, 25), - (384, 384, 15) - -- (384, 512, 15), - -- (512, 128, 100), - -- (512, 256, 25), + [ (32, 32, 200), + (32, 57, 100), + (32, 128, 40), + (32, 256, 20), + (57, 32, 200), + (57, 57, 100), + (57, 128, 40), + (57, 256, 20), + (128, 32, 200), + (128, 57, 100), + (128, 128, 40), + (128, 256, 20), + (256, 32, 200), + (256, 57, 100), + (256, 128, 40), + (256, 256, 20) + -- (256, 384, 15), + -- (256, 512, 10), + -- (384, 128, 40), + -- (384, 256, 20), + -- (384, 384, 15), + -- (384, 512, 10), + -- (512, 128, 40), + -- (512, 256, 20), -- (512, 384, 15), - -- (512, 512, 15) + -- (512, 512, 10) ] where timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t1 - t2) / t1 < 0.2 `shouldBe` True + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation - testSameTiming rh sh (senderKeySize, badKeySize, n) = do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + testSameTiming rh sh (goodKeySize, badKeySize, n) = do + (rPub, rKey) <- generateKeys goodKeySize + Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializeKey rPub) + Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, "SUB") - (sPub, sKey) <- C.generateKeyPair senderKeySize - let keyCmd = "KEY " <> C.serializePubKey sPub + (_, badKey) <- generateKeys badKeySize + -- runTimingTest rh badKey rId "SUB" + + (sPub, sKey) <- generateKeys goodKeySize + let keyCmd = "KEY " <> C.serializeKey sPub Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd) - (_, badKey) <- C.generateKeyPair badKeySize Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND 5 hello ") - timeWrongKey <- timeRepeat n $ do - Resp "cdab" _ (ERR AUTH) <- signSendRecv sh badKey ("cdab", sId, "SEND 5 hello ") - return () - timeNoQueue <- timeRepeat n $ do - Resp "dabc" _ (ERR AUTH) <- signSendRecv sh badKey ("dabc", "1234", "SEND 5 hello ") - return () Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh - similarTime timeNoQueue timeWrongKey + runTimingTest sh badKey sId "SEND 5 hello " + where + generateKeys = \case + 32 -> C.generateSignatureKeyPair 0 C.SEd25519 + 57 -> C.generateSignatureKeyPair 0 C.SEd448 + size -> C.generateSignatureKeyPair size C.SRSA + runTimingTest h badKey qId cmd = do + timeWrongKey <- timeRepeat n $ do + Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd) + return () + timeNoQueue <- timeRepeat n $ do + Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) + return () + -- (putStrLn . unwords . map show) + -- [ fromIntegral goodKeySize, + -- fromIntegral badKeySize, + -- timeWrongKey, + -- timeNoQueue, + -- timeWrongKey / timeNoQueue - 1 + -- ] + similarTime timeNoQueue timeWrongKey + +testMessageNotifications :: ATransport -> Spec +testMessageNotifications (ATransport t) = + it "should create simplex connection, subscribe notifier and deliver notifications" $ do + (sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + (nPub, nKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + smpTest4 t $ \rh sh nh1 nh2 -> do + (sId, rId, rKey) <- createAndSecureQueue rh sPub + Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, "NKEY " <> C.serializeKey nPub) + Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, "NSUB") + Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, "SEND 5 hello ") + Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh + Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, "ACK") + Resp "" _ NMSG <- tGet fromServer nh1 + Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, "NSUB") + Resp "" _ END <- tGet fromServer nh1 + Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, "SEND 11 hello again ") + Resp "" _ (MSG _ _ "hello again") <- tGet fromServer rh + Resp "" _ NMSG <- tGet fromServer nh2 + 1000 `timeout` tGet fromServer nh1 >>= \case + Nothing -> return () + Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection" samplePubKey :: ByteString samplePubKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR" -sampleSig :: ByteString -sampleSig = "\128\207*\159eq\220i!\"\157\161\130\184\226\246\232_\\\170`\180\160\230sI\154\197\211\252\SUB\246\206ELL\t9K\ESC\196?\128\215%\222\148\NAK;9\155f\164\217e\242\156\CAN9\253\r\170\174'w\211\228?\205)\215\150\255\247z\DC115\DC1{\bn\145\rKD,K\230\202d8\233\167|7y\t_S\EM\248\EOT\216\172\167d\181\224)\137\ACKo\197j#c\217\243\228.\167\228\205\144\vr\134" +sampleSig :: Maybe C.ASignature +sampleSig = "gM8qn2Vx3GkhIp2hgrji9uhfXKpgtKDmc0maxdP8GvbORUxMCTlLG8Q/gNcl3pQVOzmbZqTZZfKcGDn9DaquJ3fT5D/NKdeW//d6ETE1EXsIbpENS0QsS+bKZDjpp3w3eQlfUxn4BNisp2S14CmJBm/FaiNj2fPkLqfkzZALcoY=" syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX") - describe "NEW" do + describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX") it "many parameters" $ (sampleSig, "cdab", "", "NEW 1 " <> samplePubKey) >#> ("", "cdab", "", "ERR CMD SYNTAX") it "no signature" $ ("", "dabc", "", "NEW " <> samplePubKey) >#> ("", "dabc", "", "ERR CMD NO_AUTH") it "queue ID" $ (sampleSig, "abcd", "12345678", "NEW " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH") - describe "KEY" do + describe "KEY" $ do it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH") it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") it "many parameters" $ (sampleSig, "dabc", "12345678", "KEY 1 " <> samplePubKey) >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") @@ -399,7 +459,7 @@ syntaxTests (ATransport t) = do noParamsSyntaxTest "ACK" noParamsSyntaxTest "OFF" noParamsSyntaxTest "DEL" - describe "SEND" do + describe "SEND" $ do it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH") it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH") it "no parameters" $ (sampleSig, "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") @@ -407,16 +467,16 @@ syntaxTests (ATransport t) = do it "bad message body 1" $ (sampleSig, "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") it "bad message body 2" $ (sampleSig, "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") it "bigger body" $ (sampleSig, "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") - describe "PING" do + describe "PING" $ do it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG") - describe "broker response not allowed" do + describe "broker response not allowed" $ do it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED") where noParamsSyntaxTest :: ByteString -> Spec - noParamsSyntaxTest cmd = describe (B.unpack cmd) do + noParamsSyntaxTest cmd = describe (B.unpack cmd) $ do it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH") it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX") it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH") it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", "ERR CMD NO_AUTH") - (>#>) :: RawTransmission -> RawTransmission -> Expectation + (>#>) :: SignedRawTransmission -> SignedRawTransmission -> Expectation command >#> response = smpServerTest t command `shouldReturn` response