From 1a7336aa2637041819680c20dcfbbff0ac3d69ee Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 7 Feb 2024 00:19:12 +0000 Subject: [PATCH] make TransmissionAuth Maybe --- src/Simplex/FileTransfer/Protocol.hs | 8 ++-- src/Simplex/FileTransfer/Server.hs | 4 +- src/Simplex/Messaging/Client.hs | 4 +- .../Messaging/Notifications/Protocol.hs | 7 +-- src/Simplex/Messaging/Notifications/Server.hs | 10 ++-- src/Simplex/Messaging/Protocol.hs | 47 ++++++++----------- src/Simplex/Messaging/Server.hs | 39 ++++++++------- tests/CoreTests/BatchingTests.hs | 8 ++-- tests/NtfClient.hs | 10 ++-- tests/NtfServerTests.hs | 12 ++--- tests/SMPClient.hs | 10 ++-- tests/ServerTests.hs | 16 +++---- 12 files changed, 87 insertions(+), 88 deletions(-) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 7e36ab92e..1269f965e 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -21,6 +21,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) import Simplex.Messaging.Client (authTransmission) @@ -45,7 +46,6 @@ import Simplex.Messaging.Protocol SignedTransmission, SndPublicAuthKey, Transmission, - isAuthNone, encodeTransmission, messageTagP, tDecodeParseValidate, @@ -194,15 +194,15 @@ instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where checkCredentials (auth, _, fileId, _) cmd = case cmd of -- FNEW must not have signature and chunk ID FNEW {} - | isAuthNone auth -> Left $ CMD NO_AUTH + | isNothing auth -> Left $ CMD NO_AUTH | not (B.null fileId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd PING - | isAuthNone auth && B.null fileId -> Right cmd + | isNothing auth && B.null fileId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isAuthNone auth || B.null fileId -> Left $ CMD NO_AUTH + | isNothing auth || B.null fileId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding XFTPErrorType FileCmd where diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 10c108bad..6045d4be4 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -250,7 +250,7 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen data VerificationResult = VRVerified XFTPRequest | VRFailed -verifyXFTPTransmission :: TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult +verifyXFTPTransmission :: Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult verifyXFTPTransmission tAuth authorized fId cmd = case cmd of FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file @@ -264,7 +264,7 @@ verifyXFTPTransmission tAuth authorized fId cmd = where verify = \case Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k - _ -> dummyVerifyCmd Nothing authorized tAuth `seq` VRFailed + _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed -- TODO verify with DH authorization req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 1a0dcec8d..ed179a8d9 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -719,9 +719,7 @@ mkTransmission ProtocolClient {sessionId, thVersion = v, thAuth, client_ = PClie pure r authTransmission :: Maybe THandleAuth -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError SentRawTransmission -authTransmission thAuth pKey_ (CorrId corrId) t = case pKey_ of - Nothing -> Right (TANone, t) - Just pKey -> (,t) <$> authenticate pKey +authTransmission thAuth pKey_ (CorrId corrId) t = (,t) <$> traverse authenticate pKey_ where authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth authenticate (C.APrivateAuthKey a pk) = case a of diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index f54997007..854d7c94b 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -18,6 +18,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Kind +import Data.Maybe (isNothing) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Type.Equality import Data.Word (Word16) @@ -210,15 +211,15 @@ instance NtfEntityI e => ProtocolEncoding ErrorType (NtfCommand e) where TNEW {} -> sigNoEntity SNEW {} -> sigNoEntity PING - | isAuthNone auth && B.null entityId -> Right cmd + | isNothing auth && B.null entityId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and entity ID _ - | isAuthNone auth || B.null entityId -> Left $ CMD NO_AUTH + | isNothing auth || B.null entityId -> Left $ CMD NO_AUTH | otherwise -> Right cmd where sigNoEntity - | isAuthNone auth = Left $ CMD NO_AUTH + | isNothing auth = Left $ CMD NO_AUTH | not (B.null entityId) = Left $ CMD HAS_AUTH | otherwise = Right cmd diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index e90c6ac49..2b3254b0a 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -43,7 +43,7 @@ import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Notifications.Server.Store import Simplex.Messaging.Notifications.Server.StoreLog import Simplex.Messaging.Notifications.Transport -import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, TransmissionAuth (..), encodeTransmission, tGet, tPut) +import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Stats @@ -369,7 +369,7 @@ receive th@THandle {thAuth} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever send :: Transport c => THandle c -> NtfServerClient -> IO () send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do t <- atomically $ readTBQueue sndQ - void . liftIO $ tPut h [Right (TANone, encodeTransmission v sessionId t)] + void . liftIO $ tPut h [Right (Nothing, encodeTransmission v sessionId t)] atomically . writeTVar sndActiveAt =<< liftIO getSystemTime -- instance Show a => Show (TVar a) where @@ -405,7 +405,7 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do then do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - else pure $ dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed + else pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId NtfCmd SSubscription c -> do s_ <- atomically $ getNtfSubscription st entId @@ -413,7 +413,7 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do Just s@NtfSubData {tokenId = subTknId} -> do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - _ -> pure $ dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed + _ -> pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed where verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) @@ -424,7 +424,7 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do if verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey then positiveVerificationResult t else VRFailed - _ -> dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed + _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult verifyToken' t_ = verifyToken t_ . const diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 31d15b697..1624735bc 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -121,7 +121,6 @@ module Simplex.Messaging.Protocol noMsgFlags, messageId, messageTs, - isAuthNone, -- * Parse and serialize ProtocolMsgTag (..), @@ -172,7 +171,7 @@ import Data.Functor (($>)) import Data.Kind import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import Data.String import Data.Time.Clock.System (SystemTime (..)) import Data.Type.Equality @@ -243,7 +242,7 @@ deriving instance Show Cmd type Transmission c = (CorrId, EntityId, c) -- | signed parsed transmission, with original raw bytes and parsing error. -type SignedTransmission e c = (TransmissionAuth, Signed, Transmission (Either e c)) +type SignedTransmission e c = (Maybe TransmissionAuth, Signed, Transmission (Either e c)) type Signed = ByteString @@ -259,37 +258,31 @@ data RawTransmission = RawTransmission deriving (Show) data TransmissionAuth - = TANone - | TASignature C.ASignature + = TASignature C.ASignature | TAAuthenticator C.CbAuthenticator deriving (Eq, Show) -isAuthNone :: TransmissionAuth -> Bool -isAuthNone = \case - TANone -> True - _ -> False - -- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization -tAuthBytes :: TransmissionAuth -> ByteString +tAuthBytes :: Maybe TransmissionAuth -> ByteString tAuthBytes = \case - TANone -> "" - TASignature s -> C.signatureBytes s - TAAuthenticator (C.CbAuthenticator s) -> s + Nothing -> "" + Just (TASignature s) -> C.signatureBytes s + Just (TAAuthenticator (C.CbAuthenticator s)) -> s -decodeTAuthBytes :: ByteString -> Either String TransmissionAuth +decodeTAuthBytes :: ByteString -> Either String (Maybe TransmissionAuth) decodeTAuthBytes s - | B.null s = Right TANone - | B.length s == C.cbAuthenticatorSize = Right $ TAAuthenticator $ C.CbAuthenticator s - | otherwise = TASignature <$> C.decodeSignature s + | B.null s = Right Nothing + | B.length s == C.cbAuthenticatorSize = Right . Just . TAAuthenticator $ C.CbAuthenticator s + | otherwise = Just . TASignature <$> C.decodeSignature s -instance IsString TransmissionAuth where - fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . maybe TANone TASignature +instance IsString (Maybe TransmissionAuth) where + fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature -- | unparsed sent SMP transmission with signature, without session ID. -type SignedRawTransmission = (TransmissionAuth, SessionId, ByteString, ByteString) +type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString) -- | unparsed sent SMP transmission with signature. -type SentRawTransmission = (TransmissionAuth, ByteString) +type SentRawTransmission = (Maybe TransmissionAuth, ByteString) -- | SMP queue ID for the recipient. type RecipientId = QueueId @@ -1148,7 +1141,7 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where checkCredentials (auth, _, queueId, _) cmd = case cmd of -- NEW must have signature but NOT queue ID NEW {} - | isAuthNone auth -> Left $ CMD NO_AUTH + | isNothing auth -> 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 @@ -1157,11 +1150,11 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where | otherwise -> Right cmd -- PING must not have queue ID or signature PING - | isAuthNone auth && B.null queueId -> Right cmd + | isNothing auth && B.null queueId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isAuthNone auth || B.null queueId -> Left $ CMD NO_AUTH + | isNothing auth || B.null queueId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding ErrorType Cmd where @@ -1417,11 +1410,11 @@ tDecodeParseValidate sessionId v = \case | sessId == sessionId -> let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission - | otherwise -> (TANone, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession)) + | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession)) Left _ -> tError "" where tError :: ByteString -> SignedTransmission err cmd - tError corrId = (TANone, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock)) + tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock)) tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd tParseValidate signed t@(sig, corrId, entityId, command) = diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 52fd261ba..6ad78435b 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -443,7 +443,7 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do forever $ do ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ -- TODO we can authorize responses as well - void . liftIO . tPut h $ L.map (\t -> Right (TANone, encodeTransmission v sessionId t)) ts + void . liftIO . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission v sessionId t)) ts atomically . writeTVar sndActiveAt =<< liftIO getSystemTime where tOrder :: Transmission BrokerMsg -> Int @@ -467,7 +467,7 @@ disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expC data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed -verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult +verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdAuthorization auth_ tAuth authorized k @@ -482,27 +482,35 @@ verifyTransmission auth_ tAuth authorized queueId cmd = q_ <- atomically $ getQueue st party queueId pure $ case q_ of Right q -> Just q `verified` f q - _ -> dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed + _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed verifyMaybe :: Maybe C.APublicAuthKey -> Bool - verifyMaybe = maybe (isAuthNone tAuth) $ verifyCmdAuthorization auth_ tAuth authorized + verifyMaybe = maybe (isNothing tAuth) $ verifyCmdAuthorization auth_ tAuth authorized verified q cond = if cond then VRVerified q else VRFailed -verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool -verifyCmdAuthorization auth_ tAuth authorized key = case tAuth of - TANone -> False - TASignature sig -> verifySig key sig - TAAuthenticator s -> verifyAuth key s +verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool +verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth + -- TANone -> False + -- TASignature sig -> verifySig key sig + -- TAAuthenticator s -> verifyAuth key s where - verifySig :: C.APublicAuthKey -> C.ASignature -> Bool - verifySig (C.APublicAuthKey a k) sig@(C.ASignature a' s) = - case testEquality a a' of + verify :: C.APublicAuthKey -> TransmissionAuth -> Bool + verify (C.APublicAuthKey a k) = \case + TASignature sig@(C.ASignature a' s) -> case testEquality a a' of Just Refl | C.signatureSize k == C.signatureSize s -> C.verify' k s authorized _ -> dummyVerifyCmd auth_ authorized (TASignature sig) `seq` False - verifyAuth :: C.APublicAuthKey -> C.CbAuthenticator -> Bool - verifyAuth (C.APublicAuthKey a k) s = - case a of + TAAuthenticator s -> case a of C.SX25519 -> verifyCmdAuth auth_ k s authorized _ -> dummyVerifyCmd auth_ authorized (TAAuthenticator s) `seq` False + -- verifySig :: C.APublicAuthKey -> C.ASignature -> Bool + -- verifySig (C.APublicAuthKey a k) sig@(C.ASignature a' s) = + -- case testEquality a a' of + -- Just Refl | C.signatureSize k == C.signatureSize s -> C.verify' k s authorized + -- _ -> dummyVerifyCmd auth_ authorized (TASignature sig) `seq` False + -- verifyAuth :: C.APublicAuthKey -> C.CbAuthenticator -> Bool + -- verifyAuth (C.APublicAuthKey a k) s = + -- case a of + -- C.SX25519 -> verifyCmdAuth auth_ k s authorized + -- _ -> dummyVerifyCmd auth_ authorized (TAAuthenticator s) `seq` False verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool verifyCmdAuth auth_ k authenticator authorized = case auth_ of @@ -511,7 +519,6 @@ verifyCmdAuth auth_ k authenticator authorized = case auth_ of dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool dummyVerifyCmd auth_ authorized = \case - TANone -> False TASignature (C.ASignature a s) -> C.verify' (dummyPublicKey a) s authorized TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 5ca7fce2d..f12fe0755 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -135,14 +135,14 @@ testClientBatchWithLargeMessage = do (length rs1', length rs2') `shouldBe` (70, 90) all lenOk [s1', s2'] `shouldBe` True -randomSUB :: ByteString -> IO (Either TransportError (TransmissionAuth, ByteString)) +randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSUB sessId = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g corrId <- atomically $ CorrId <$> C.randomBytes 3 g (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, rId, Cmd SRecipient SUB) - pure $ Right (TASignature $ C.sign rpKey s, s) + pure $ Right (Just . TASignature $ C.sign rpKey s, s) randomSUBCmd :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd c = do @@ -151,7 +151,7 @@ randomSUBCmd c = do (_, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB) -randomSEND :: ByteString -> Int -> IO (Either TransportError (TransmissionAuth, ByteString)) +randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSEND sessId len = do g <- C.newRandom sId <- atomically $ C.randomBytes 24 g @@ -159,7 +159,7 @@ randomSEND sessId len = do (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g msg <- atomically $ C.randomBytes len g let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, sId, Cmd SSender $ SEND noMsgFlags msg) - pure $ Right (TASignature $ C.sign rpKey s, s) + pure $ Right (Just . TASignature $ C.sign rpKey s, s) randomSENDCmd :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) randomSENDCmd c len = do diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 427836e23..f9091f627 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -137,18 +137,18 @@ ntfServerTest :: forall c smp. (Transport c, Encoding smp) => TProxy c -> - (TransmissionAuth, ByteString, ByteString, smp) -> - IO (TransmissionAuth, ByteString, ByteString, BrokerMsg) + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h where - tPut' :: THandle c -> (TransmissionAuth, ByteString, ByteString, smp) -> IO () + tPut' :: THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do let t' = smpEncode (sessionId, corrId, queueId, smp) [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do - [(TANone, _, (CorrId corrId, qId, Right cmd))] <- tGet h - pure (TANone, corrId, qId, cmd) + [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h + pure (Nothing, corrId, qId, cmd) ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation ntfTest _ test' = runNtfTest test' `shouldReturn` () diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 002615215..0ce6f923d 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -59,15 +59,15 @@ ntfSyntaxTests (ATransport t) = do where (>#>) :: Encoding smp => - (TransmissionAuth, ByteString, ByteString, smp) -> - (TransmissionAuth, ByteString, ByteString, BrokerMsg) -> + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -> Expectation command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command)) -sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) Right () <- tPut1 h (sgn, t) @@ -80,9 +80,9 @@ signSendRecvNtf h@THandle {thVersion, sessionId} (C.APrivateAuthKey a pk) (corrI tGet1 h where authorize t = case a of - C.SEd25519 -> TASignature . C.ASignature C.SEd25519 $ C.sign' pk t - C.SEd448 -> TASignature . C.ASignature C.SEd448 $ C.sign' pk t - _ -> TANone + C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t + C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t + _ -> Nothing (.->) :: J.Value -> J.Key -> Either String ByteString v .-> key = diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 2464d8c6d..369738f83 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -159,18 +159,18 @@ smpServerTest :: forall c smp. (Transport c, Encoding smp) => TProxy c -> - (TransmissionAuth, ByteString, ByteString, smp) -> - IO (TransmissionAuth, ByteString, ByteString, BrokerMsg) + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h where - tPut' :: THandle c -> (TransmissionAuth, ByteString, ByteString, smp) -> IO () + tPut' :: THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do let t' = smpEncode (sessionId, corrId, queueId, smp) [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do - [(TANone, _, (CorrId corrId, qId, Right cmd))] <- tGet h - pure (TANone, corrId, qId, cmd) + [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h + pure (Nothing, corrId, qId, cmd) smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> IO ()) -> Expectation smpTest _ test' = runSmpTest test' `shouldReturn` () diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 486787738..f78408c48 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -72,7 +72,7 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) Right () <- tPut1 h (sgn, t) @@ -85,9 +85,9 @@ signSendRecv h@THandle {thVersion, sessionId} (C.APrivateAuthKey a pk) (corrId, tGet1 h where authorize t = case a of - C.SEd25519 -> TASignature . C.ASignature C.SEd25519 $ C.sign' pk t - C.SEd448 -> TASignature . C.ASignature C.SEd448 $ C.sign' pk t - _ -> TANone + C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t + C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t + _ -> Nothing tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) tPut1 h t = do @@ -897,8 +897,8 @@ samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ sampleDhPubKey :: C.PublicKey 'C.X25519 sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ=" -sampleSig :: TransmissionAuth -sampleSig = TASignature "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" +sampleSig :: Maybe TransmissionAuth +sampleSig = Just $ TASignature "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" noAuth :: (Char, Maybe BasicAuth) noAuth = ('A', Nothing) @@ -942,7 +942,7 @@ syntaxTests (ATransport t) = do it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) (>#>) :: Encoding smp => - (TransmissionAuth, ByteString, ByteString, smp) -> - (TransmissionAuth, ByteString, ByteString, BrokerMsg) -> + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -> Expectation command >#> response = withFrozenCallStack $ smpServerTest t command `shouldReturn` response