From bedefb11b31579899e7dead056ca4db10d111812 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 15 Oct 2020 11:55:10 +0100 Subject: [PATCH] SUSPEND and DELETE connection --- src/ConnStore.hs | 12 ++++---- src/ConnStore/STM.hs | 65 ++++++++++++++++++++++++++++++------------- src/Server.hs | 23 +++++++++++---- tests/Test.hs | 66 +++++++++++++++++++++++++++++++++++++++++--- 4 files changed, 133 insertions(+), 33 deletions(-) diff --git a/src/ConnStore.hs b/src/ConnStore.hs index 58d1e4e57..6a8bf6946 100644 --- a/src/ConnStore.hs +++ b/src/ConnStore.hs @@ -12,17 +12,19 @@ data Connection = Connection recipientKey :: PublicKey, senderId :: ConnId, senderKey :: Maybe PublicKey, - active :: Bool + status :: ConnStatus } +data ConnStatus = ConnActive | ConnSuspended + class MonadConnStore s m where createConn :: s -> RecipientKey -> m (Either ErrorType Connection) getConn :: s -> Sing (a :: Party) -> ConnId -> m (Either ErrorType Connection) secureConn :: s -> RecipientId -> SenderKey -> m (Either ErrorType ()) + suspendConn :: s -> RecipientId -> m (Either ErrorType ()) + deleteConn :: s -> RecipientId -> m (Either ErrorType ()) --- suspendConn :: RecipientId -> m (Either ErrorType ()) --- deleteConn :: RecipientId -> m (Either ErrorType ()) - +-- TODO stub newConnection :: RecipientKey -> Connection newConnection rKey = Connection @@ -30,5 +32,5 @@ newConnection rKey = recipientKey = rKey, senderId = "2", senderKey = Nothing, - active = True + status = ConnActive } diff --git a/src/ConnStore/STM.hs b/src/ConnStore/STM.hs index d3e8befdd..46cfb2ac4 100644 --- a/src/ConnStore/STM.hs +++ b/src/ConnStore/STM.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,6 +14,7 @@ import ConnStore import Control.Monad.IO.Unlift import Data.Map (Map) import qualified Data.Map as M +import Data.Singletons import Transmission import UnliftIO.STM @@ -26,38 +29,62 @@ newConnStore :: STM STMConnStore newConnStore = newTVar ConnStoreData {connections = M.empty, senders = M.empty} instance MonadUnliftIO m => MonadConnStore STMConnStore m where - createConn store rKey = atomically do + createConn :: STMConnStore -> RecipientKey -> m (Either ErrorType Connection) + createConn store rKey = atomically $ do db <- readTVar store let c@Connection {recipientId = rId, senderId = sId} = newConnection rKey db' = - ConnStoreData + db { connections = M.insert rId c (connections db), senders = M.insert sId rId (senders db) } writeTVar store db' return $ Right c - -- TODO do not return suspended connections - getConn store SRecipient rId = atomically do + getConn :: STMConnStore -> Sing (p :: Party) -> ConnId -> m (Either ErrorType Connection) + getConn store SRecipient rId = atomically $ do db <- readTVar store return $ getRcpConn db rId - getConn store SSender sId = atomically do + getConn store SSender sId = atomically $ do db <- readTVar store - return $ maybe (Left AUTH) (getRcpConn db) $ M.lookup sId $ senders db - getConn _ SBroker _ = atomically do + let rId = M.lookup sId $ senders db + return $ maybe (Left AUTH) (getRcpConn db) rId + getConn _ SBroker _ = return $ Left INTERNAL - secureConn store rId sKey = atomically do - db <- readTVar store - let conn = getRcpConn db rId - either (return . Left) (updateConn db) conn - where - updateConn db c = case senderKey c of - Just _ -> return $ Left AUTH - Nothing -> do - let db' = db {connections = M.insert rId c {senderKey = Just sKey} (connections db)} - writeTVar store db' - return $ Right () + secureConn store rId sKey = updateConnections store rId $ \db c -> + case senderKey c of + Just _ -> (Left AUTH, db) + _ -> (Right (), db {connections = M.insert rId c {senderKey = Just sKey} (connections db)}) + + suspendConn :: STMConnStore -> RecipientId -> m (Either ErrorType ()) + suspendConn store rId = updateConnections store rId $ \db c -> + (Right (), db {connections = M.insert rId c {status = ConnSuspended} (connections db)}) + + deleteConn :: STMConnStore -> RecipientId -> m (Either ErrorType ()) + deleteConn store rId = updateConnections store rId $ \db c -> + ( Right (), + db + { connections = M.delete rId (connections db), + senders = M.delete (senderId c) (senders db) + } + ) + +updateConnections :: + MonadUnliftIO m => + STMConnStore -> + RecipientId -> + (ConnStoreData -> Connection -> (Either ErrorType (), ConnStoreData)) -> + m (Either ErrorType ()) +updateConnections store rId update = atomically $ do + db <- readTVar store + let conn = getRcpConn db rId + either (return . Left) (_update db) conn + where + _update db c = do + let (res, db') = update db c + writeTVar store db' + return res getRcpConn :: ConnStoreData -> RecipientId -> Either ErrorType Connection getRcpConn db rId = maybe (Left AUTH) Right . M.lookup rId $ connections db diff --git a/src/Server.hs b/src/Server.hs index ad65b6945..71c5df9b7 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -83,15 +83,19 @@ client h Client {queue} = loop processCommand connId cmd = do st <- asks connStore case cmd of - Cmd SRecipient (CREATE recipientKey) -> + Cmd SRecipient (CREATE rKey) -> either (mkSigned "" . ERROR) connResponce - <$> createConn st recipientKey + <$> createConn st rKey Cmd SRecipient SUB -> do -- TODO message subscription return ok - Cmd SRecipient (SECURE senderKey) -> do - mkSigned connId . either ERROR (const OK) - <$> secureConn st connId senderKey + Cmd SRecipient (SECURE sKey) -> okResponse <$> secureConn st connId sKey + Cmd SRecipient SUSPEND -> okResponse <$> suspendConn st connId + Cmd SRecipient DELETE -> okResponse <$> deleteConn st connId + Cmd SSender (SEND msgBody) -> do + -- TODO message delivery + mkSigned connId . either ERROR (deliverTo msgBody) + <$> getConn st SSender connId Cmd SBroker _ -> return (connId, cmd) Cmd _ _ -> return ok where @@ -103,3 +107,12 @@ client h Client {queue} = loop connResponce :: Connection -> Signed connResponce Connection {recipientId = rId, senderId = sId} = mkSigned rId $ CONN rId sId + + okResponse :: Either ErrorType () -> Signed + okResponse = mkSigned connId . either ERROR (const OK) + + -- TODO stub + deliverTo :: MsgBody -> Connection -> Command 'Broker + deliverTo _msgBody conn = case status conn of + ConnActive -> OK + ConnSuspended -> ERROR AUTH diff --git a/tests/Test.hs b/tests/Test.hs index 1bba3579f..caa839706 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -17,7 +17,8 @@ main :: IO () main = hspec do describe "SMP syntax" syntaxTests describe "SMP connections" do - createSecureSendTest + testCreateSecure + testCreateDelete pattern Resp :: ConnId -> Command 'Broker -> TransmissionOrError pattern Resp connId command = ("", (connId, Right (Cmd SBroker command))) @@ -31,8 +32,8 @@ sendRecv h t = tPutRaw h t >> tGet fromServer h (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion (actual, expected) #== message = assertEqual message expected actual -createSecureSendTest :: SpecWith () -createSecureSendTest = do +testCreateSecure :: SpecWith () +testCreateSecure = do it "CREATE and SECURE connection, SEND messages (no delivery yet)" $ smpTest \h -> do Resp rId (CONN rId1 sId) <- sendRecv h ("", "", "CREATE 123") @@ -63,7 +64,64 @@ createSecureSendTest = do (ok3, OK) #== "accepts signed SEND" Resp _ err5 <- sendRecv h ("", sId, "SEND :hello") - (err5, ERROR AUTH) #== "accepts unsigned SEND" + (err5, ERROR AUTH) #== "rejects unsigned SEND" + +testCreateDelete :: SpecWith () +testCreateDelete = do + it "CREATE, SUSPEND and DELETE connection, SEND messages (no delivery yet)" $ + smpTest \h -> do + Resp rId (CONN rId1 sId) <- sendRecv h ("", "", "CREATE 123") + (rId1, rId) #== "creates connection" + + Resp _ ok1 <- sendRecv h ("123", rId, "SECURE 456") + (ok1, OK) #== "secures connection" + + Resp _ ok2 <- sendRecv h ("456", sId, "SEND :hello") + (ok2, OK) #== "accepts signed SEND" + + Resp _ err1 <- sendRecv h ("1234", rId, "SUSPEND") + (err1, ERROR AUTH) #== "rejects SUSPEND with wrong signature (password atm)" + + Resp _ err2 <- sendRecv h ("123", sId, "SUSPEND") + (err2, ERROR AUTH) #== "rejects SUSPEND with sender's ID" + + Resp rId2 ok3 <- sendRecv h ("123", rId, "SUSPEND") + (ok3, OK) #== "suspends connection" + (rId2, rId) #== "same connection ID in response 2" + + Resp _ err3 <- sendRecv h ("456", sId, "SEND :hello") + (err3, ERROR AUTH) #== "rejects signed SEND" + + Resp _ err4 <- sendRecv h ("", sId, "SEND :hello") + (err4, ERROR AUTH) #== "reject unsigned SEND too" + + Resp _ ok4 <- sendRecv h ("123", rId, "SUSPEND") + (ok4, OK) #== "accepts SUSPEND when suspended" + + Resp _ ok5 <- sendRecv h ("123", rId, "SUB") + (ok5, OK) #== "accepts SUB when suspended" + + Resp _ err5 <- sendRecv h ("1234", rId, "DELETE") + (err5, ERROR AUTH) #== "rejects DELETE with wrong signature (password atm)" + + Resp _ err6 <- sendRecv h ("123", sId, "DELETE") + (err6, ERROR AUTH) #== "rejects DELETE with sender's ID" + + Resp rId3 ok6 <- sendRecv h ("123", rId, "DELETE") + (ok6, OK) #== "deletes connection" + (rId3, rId) #== "same connection ID in response 3" + + Resp _ err7 <- sendRecv h ("456", sId, "SEND :hello") + (err7, ERROR AUTH) #== "rejects signed SEND when deleted" + + Resp _ err8 <- sendRecv h ("", sId, "SEND :hello") + (err8, ERROR AUTH) #== "rejects unsigned SEND too when deleted" + + Resp _ err9 <- sendRecv h ("123", rId, "SUSPEND") + (err9, ERROR AUTH) #== "rejects SUSPEND when deleted" + + Resp _ err10 <- sendRecv h ("123", rId, "SUB") + (err10, ERROR AUTH) #== "rejects SUB when deleted" syntaxTests :: SpecWith () syntaxTests = do