diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index dc69ea339..d727ed8e4 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1083,7 +1083,6 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, let (es, ts') = partitionEithers $ L.toList ts errs = map (second ERR) es case ts' of - [] -> write sndQ errs (_, _, (_, _, Cmd p cmd)) : _ -> do let service = peerClientService =<< thAuth (errs', cmds) <- partitionEithers <$> case batchParty p of @@ -1095,6 +1094,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, _ -> mapM (\t -> verified stats t =<< verifyTransmission ms service thAuth t) ts' write rcvQ cmds write sndQ $ errs ++ errs' + [] -> write sndQ errs where sameParty :: SParty p -> SignedTransmission Cmd -> Bool sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p' @@ -1184,14 +1184,14 @@ verifyTransmission ms service thAuth t@(_, _, (_, queueId, Cmd p _)) = case queu verifyLoadedQueue :: Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s verifyLoadedQueue service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case Right q -> verifyQueueTransmission service thAuth t (Just q) - Left AUTH -> (dummyVerifyCmd thAuth tAuth authorized corrId) `seq` VRFailed AUTH + Left AUTH -> dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH Left e -> VRFailed e verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s -verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, cmd@(Cmd p command))) q_ +verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@(Cmd p cmd))) q_ | not checkRole = VRFailed $ CMD PROHIBITED | not verifyServiceSig = VRFailed SERVICE - | otherwise = vc p command + | otherwise = vc p cmd where vc :: SParty p -> Command p -> VerificationResult s -- this pattern match works with ghc8.10.7, flat case sees it as non-exhastive. vc SCreator (NEW NewQueueReq {rcvAuthKey = k}) = verifiedWith k @@ -1219,7 +1219,7 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, cmd@(Cmd _ -> VRFailed SERVICE -- this function verify service signature for commands that use it in service sessions verifyServiceSig - | useServiceAuth cmd = case (service, serviceSig) of + | useServiceAuth command = case (service, serviceSig) of (Just THClientService {serviceKey = k}, Just s) -> C.verify' k s authorized (Nothing, Nothing) -> True _ -> False @@ -1229,7 +1229,7 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, cmd@(Cmd (Just THClientService {serviceCertHash = XV.Fingerprint fp}, Just _) -> fp <> authorized _ -> authorized dummyVerify :: VerificationResult s - dummyVerify = (dummyVerifyCmd thAuth tAuth authorized corrId) `seq` VRFailed AUTH + dummyVerify = dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH -- That a specific command requires queue signature verification is determined by `queueParty`, -- it should be coordinated with the case in this function (`verifyQueueTransmission`) verifyQueue :: ((StoreQueue s, QueueRec) -> VerificationResult s) -> VerificationResult s @@ -1274,11 +1274,11 @@ verifyCmdAuth thAuth k authenticator authorized (CorrId corrId) = case thAuth of Nothing -> False dummyVerifyCmd :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> Maybe Bool -dummyVerifyCmd thAuth tAuth authorized corrId = verify . fst <$> tAuth +dummyVerifyCmd thAuth tAuth authorized corrId = verify <$> tAuth where verify = \case - TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized - TAAuthenticator s -> verifyCmdAuth thAuth dummyKeyX25519 s authorized corrId + (TASignature (C.ASignature a s), _) -> C.verify' (dummySignKey a) s authorized + (TAAuthenticator s, _) -> verifyCmdAuth thAuth dummyKeyX25519 s authorized corrId -- 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 @@ -1934,22 +1934,21 @@ client pure r3 where rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s) - rejectOrVerify clntThAuth = - \case - Left (corrId', entId', e) -> pure $ Left (corrId', entId', ERR e) - Right t'@(_, _, t''@(corrId', entId', cmd')) - | allowed -> liftIO $ verified <$> verifyTransmission ms Nothing clntThAuth t' - | otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) - where - allowed = case cmd' of - Cmd SSender SEND {} -> True - Cmd SSender (SKEY _) -> True - Cmd SSenderLink (LKEY _) -> True - Cmd SSenderLink LGET -> True - _ -> False - verified = \case - VRVerified q -> Right (q, t'') - VRFailed e -> Left (corrId', entId', ERR e) + rejectOrVerify clntThAuth = \case + Left (corrId', entId', e) -> pure $ Left (corrId', entId', ERR e) + Right t'@(_, _, t''@(corrId', entId', cmd')) + | allowed -> liftIO $ verified <$> verifyTransmission ms Nothing clntThAuth t' + | otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) + where + allowed = case cmd' of + Cmd SSender SEND {} -> True + Cmd SSender (SKEY _) -> True + Cmd SSenderLink (LKEY _) -> True + Cmd SSenderLink LGET -> True + _ -> False + verified = \case + VRVerified q -> Right (q, t'') + VRFailed e -> Left (corrId', entId', ERR e) deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> IO (Transmission BrokerMsg) deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $ diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index ef0ee4822..e2d139ffb 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -112,13 +112,13 @@ getQueue :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (E getQueue st = getQueue_ (queueStore st) (mkQueue st) {-# INLINE getQueue #-} +getQueueRec :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) +getQueueRec st party qId = getQueue st party qId $>>= readQueueRec + getQueues :: (MsgStoreClass s, BatchParty p) => s -> SParty p -> [QueueId] -> IO [Either ErrorType (StoreQueue s)] getQueues st = getQueues_ (queueStore st) (mkQueue st) {-# INLINE getQueues #-} -getQueueRec :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) -getQueueRec st party qId = getQueue st party qId $>>= readQueueRec - getQueueRecs :: (MsgStoreClass s, BatchParty p) => s -> SParty p -> [QueueId] -> IO [Either ErrorType (StoreQueue s, QueueRec)] getQueueRecs st party qIds = getQueues st party qIds >>= mapM (fmap join . mapM readQueueRec) diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index e8a4c60cd..1b7f26e3d 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -435,15 +435,15 @@ testNoProxy :: AStoreType -> IO () testNoProxy msType = do withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do - (_, _, Right reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) - reply `shouldBe` (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) + (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) + reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) testProxyAuth :: AStoreType -> IO () testProxyAuth msType = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do - (_, _, Right reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong") - reply `shouldBe` (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) + (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong") + reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where proxyCfgAuth = updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth = Just "correct"}