dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-11 06:06:59 +00:00
Code Issues Packages Projects Releases Wiki Activity

make TransmissionAuth Maybe

Browse Source
This commit is contained in:
Evgeny Poberezkin
2024-02-07 00:19:12 +00:00
parent 3efdd7a256
commit 1a7336aa26
12 changed files with 87 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/FileTransfer/Protocol.hs
+4 -4
View File
@@ -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
src/Simplex/FileTransfer/Server.hs
+2 -2
View File
@@ -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
src/Simplex/Messaging/Client.hs
+1 -3
View File
@@ -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
src/Simplex/Messaging/Notifications/Protocol.hs
+4 -3
View File
@@ -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
src/Simplex/Messaging/Notifications/Server.hs
+5 -5
View File
@@ -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
src/Simplex/Messaging/Protocol.hs
+20 -27
View File
@@ -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) =
src/Simplex/Messaging/Server.hs
+23 -16
View File
@@ -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
tests/CoreTests/BatchingTests.hs
+4 -4
View File
@@ -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
tests/NtfClient.hs
+5 -5
View File
@@ -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` ()
tests/NtfServerTests.hs
+6 -6
View File
@@ -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 =
tests/SMPClient.hs
+5 -5
View File
@@ -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` ()
tests/ServerTests.hs
+8 -8
View File
@@ -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