From 2ba27ed852b60717a2a69fcdba49db1cc7a6a2f0 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 14 Oct 2020 21:03:37 +0100 Subject: [PATCH] SECURE command, tests --- src/ConnStore.hs | 12 ++--- src/ConnStore/STM.hs | 37 +++++++++----- src/Server.hs | 45 +++++++++++------ tests/SMPClient.hs | 42 ++++++++++------ tests/Test.hs | 114 +++++++++++++++++++++++++++++-------------- 5 files changed, 165 insertions(+), 85 deletions(-) diff --git a/src/ConnStore.hs b/src/ConnStore.hs index 711eb8b5e..58d1e4e57 100644 --- a/src/ConnStore.hs +++ b/src/ConnStore.hs @@ -7,8 +7,6 @@ module ConnStore where import Data.Singletons import Transmission -type SMPResult a = Either ErrorType a - data Connection = Connection { recipientId :: ConnId, recipientKey :: PublicKey, @@ -18,12 +16,12 @@ data Connection = Connection } class MonadConnStore s m where - createConn :: s -> RecipientKey -> m (SMPResult Connection) - getConn :: s -> Sing (a :: Party) -> ConnId -> m (SMPResult Connection) + createConn :: s -> RecipientKey -> m (Either ErrorType Connection) + getConn :: s -> Sing (a :: Party) -> ConnId -> m (Either ErrorType Connection) + secureConn :: s -> RecipientId -> SenderKey -> m (Either ErrorType ()) --- secureConn :: RecipientId -> SenderKey -> m (SMPResult ()) --- suspendConn :: RecipientId -> m (SMPResult ()) --- deleteConn :: RecipientId -> m (SMPResult ()) +-- suspendConn :: RecipientId -> m (Either ErrorType ()) +-- deleteConn :: RecipientId -> m (Either ErrorType ()) newConnection :: RecipientKey -> Connection newConnection rKey = diff --git a/src/ConnStore/STM.hs b/src/ConnStore/STM.hs index 11941ad7b..d3e8befdd 100644 --- a/src/ConnStore/STM.hs +++ b/src/ConnStore/STM.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,27 +26,38 @@ 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 store rKey = atomically do db <- readTVar store - let conn@Connection {senderId, recipientId} = newConnection rKey + let c@Connection {recipientId = rId, senderId = sId} = newConnection rKey db' = ConnStoreData - { connections = M.insert recipientId conn (connections db), - senders = M.insert senderId recipientId (senders db) + { connections = M.insert rId c (connections db), + senders = M.insert sId rId (senders db) } writeTVar store db' - return $ Right conn - getConn store SRecipient rId = atomically $ do + return $ Right c + + -- TODO do not return suspended connections + 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 $ maybeAuth (getRcpConn db) $ M.lookup sId $ senders db - getConn _ SBroker _ = atomically $ do + return $ maybe (Left AUTH) (getRcpConn db) $ M.lookup sId $ senders db + getConn _ SBroker _ = atomically do return $ Left INTERNAL -maybeAuth :: (a -> Either ErrorType b) -> Maybe a -> Either ErrorType b -maybeAuth = maybe (Left AUTH) + 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 () getRcpConn :: ConnStoreData -> RecipientId -> Either ErrorType Connection -getRcpConn db rId = maybeAuth Right $ M.lookup rId $ connections db +getRcpConn db rId = maybe (Left AUTH) Right . M.lookup rId $ connections db diff --git a/src/Server.hs b/src/Server.hs index f3c4f04f5..9524623f2 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -26,12 +26,12 @@ import qualified UnliftIO.Exception as E import UnliftIO.IO import UnliftIO.STM -runSMPServer :: ServiceName -> Natural -> IO () +runSMPServer :: MonadUnliftIO m => ServiceName -> Natural -> m () runSMPServer port queueSize = do env <- atomically $ newEnv port queueSize runReaderT (runTCPServer runClient) env -runTCPServer :: (MonadReader Env m, MonadUnliftIO m) => (Handle -> m ()) -> m () +runTCPServer :: (MonadUnliftIO m, MonadReader Env m) => (Handle -> m ()) -> m () runTCPServer server = E.bracket startTCPServer (liftIO . close) $ \sock -> forever $ do h <- acceptTCPConn sock @@ -58,7 +58,7 @@ receive h Client {queue} = forever $ do verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => Signature -> ConnId -> Cmd -> m Signed verifyTransmission signature connId cmd = do (connId,) <$> case cmd of - Cmd SBroker _ -> return $ smpErr INTERNAL + Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used Cmd SRecipient (CREATE _) -> return cmd Cmd SRecipient _ -> withConnection SRecipient $ verifySignature . recipientKey Cmd SSender (SEND _) -> withConnection SSender $ verifySend . senderKey @@ -80,18 +80,35 @@ verifyTransmission signature connId cmd = do smpErr e = Cmd SBroker $ ERROR e authErr = smpErr AUTH -client :: (MonadUnliftIO m, MonadReader Env m) => Handle -> Client -> m () +client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Handle -> Client -> m () client h Client {queue} = loop where loop = forever $ do (connId, cmd) <- atomically $ readTBQueue queue - response <- case cmd of - Cmd SRecipient (CREATE recipientKey) -> do - store <- asks connStore - conn <- createConn store recipientKey - return . Cmd SBroker $ case conn of - Right Connection {recipientId, senderId} -> CONN recipientId senderId - Left e -> ERROR e - Cmd SBroker _ -> return cmd - Cmd _ _ -> return $ Cmd SBroker OK - tPut h ("", (connId, response)) -- empty signature + signed <- processCommand connId cmd + tPut h ("", signed) + + processCommand :: ConnId -> Cmd -> m Signed + processCommand connId cmd = do + st <- asks connStore + case cmd of + Cmd SRecipient (CREATE recipientKey) -> + either (mkSigned "" . ERROR) connResponce + <$> createConn st recipientKey + 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 SBroker _ -> return (connId, cmd) + Cmd _ _ -> return ok + where + ok :: Signed + ok = (connId, Cmd SBroker OK) + + mkSigned :: ConnId -> Command 'Broker -> Signed + mkSigned cId command = (cId, Cmd SBroker command) + + connResponce :: Connection -> Signed + connResponce Connection {recipientId = rId, senderId = sId} = mkSigned rId $ CONN rId sId diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 14575d06d..f41349eb1 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -2,24 +2,22 @@ module SMPClient where -import Control.Concurrent -import qualified Control.Exception as E +import Control.Monad +import Control.Monad.IO.Unlift import Network.Socket import Numeric.Natural import Server -import System.IO import Transmission import Transport +import UnliftIO.Concurrent +import qualified UnliftIO.Exception as E +import UnliftIO.IO -runSMPClient :: HostName -> ServiceName -> (Handle -> IO a) -> IO a -runSMPClient host port client = withSocketsDo $ do +startTCPClient :: MonadIO m => HostName -> ServiceName -> m Handle +startTCPClient host port = liftIO . withSocketsDo $ do threadDelay 1 -- TODO hack: thread delay for SMP server to start addr <- resolve - E.bracket (open addr) hClose $ \h -> do - line <- getLn h - if line == "Welcome to SMP" - then client h - else error "not connected" + open addr where resolve = do let hints = defaultHints {addrSocketType = Stream} @@ -29,6 +27,18 @@ runSMPClient host port client = withSocketsDo $ do connect sock $ addrAddress addr getSocketHandle sock +runTCPClient :: MonadUnliftIO m => HostName -> ServiceName -> (Handle -> m a) -> m a +runTCPClient host port client = do + E.bracket (startTCPClient host port) (liftIO . hClose) client + +runSMPClient :: MonadUnliftIO m => HostName -> ServiceName -> (Handle -> m a) -> m a +runSMPClient host port client = + runTCPClient host port $ \h -> do + line <- getLn h + if line == "Welcome to SMP" + then client h + else error "not connected" + testPort :: ServiceName testPort = "5000" @@ -40,13 +50,15 @@ queueSize = 2 type TestTransmission = (Signature, ConnId, String) -smpServerTest :: [TestTransmission] -> IO [TestTransmission] -smpServerTest commands = +runSmpTest :: MonadUnliftIO m => (Handle -> m a) -> m a +runSmpTest test = E.bracket (forkIO $ runSMPServer testPort queueSize) - killThread - \_ -> runSMPClient "localhost" testPort $ - \h -> mapM (sendReceive h) commands + (liftIO . killThread) + \_ -> runSMPClient "localhost" testPort test + +smpServerTest :: [TestTransmission] -> IO [TestTransmission] +smpServerTest commands = runSmpTest \h -> mapM (sendReceive h) commands where sendReceive :: Handle -> TestTransmission -> IO TestTransmission sendReceive h t = tPutRaw h t >> tGetRaw h diff --git a/tests/Test.hs b/tests/Test.hs index c492314ab..3a4907fa2 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,47 +1,89 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} import SMPClient +import System.IO (Handle) import Test.Hspec +import Transmission +import Transport (>#>) :: [TestTransmission] -> [TestTransmission] -> Expectation -commands >#> responses = smpServerTest commands `shouldReturn` responses +commands >#> responses = smpServerTest2 commands `shouldReturn` responses main :: IO () main = hspec do - describe "SMP syntax" do - it "unknown command" $ [("", "123", "HELLO")] >#> [("", "123", "ERROR UNKNOWN")] - describe "CREATE" do - it "no parameters" $ [("", "", "CREATE")] >#> [("", "", "ERROR SYNTAX 2")] - it "many parameters" $ [("", "", "CREATE 1 2")] >#> [("", "", "ERROR SYNTAX 2")] - it "has signature" $ [("123", "", "CREATE 123")] >#> [("", "", "ERROR SYNTAX 4")] - it "connection ID" $ [("", "1", "CREATE 123")] >#> [("", "1", "ERROR SYNTAX 4")] - noParamsSyntaxTest "SUB" - oneParamSyntaxTest "SECURE" - oneParamSyntaxTest "DELMSG" - noParamsSyntaxTest "SUSPEND" - noParamsSyntaxTest "DELETE" - describe "SEND" do - it "valid syntax 1" $ [("123", "1", "SEND :hello")] >#> [("", "1", "ERROR AUTH")] - it "valid syntax 2" $ [("123", "1", "SEND 11\nhello there\n")] >#> [("", "1", "ERROR AUTH")] - it "no parameters" $ [("123", "1", "SEND")] >#> [("", "1", "ERROR SYNTAX 2")] - it "many parameters" $ [("123", "1", "SEND 11 hello")] >#> [("", "1", "ERROR SYNTAX 2")] - it "no connection ID" $ [("123", "", "SEND :hello")] >#> [("", "", "ERROR SYNTAX 5")] - it "bad message body" $ [("123", "1", "SEND hello")] >#> [("", "1", "ERROR SYNTAX 6")] - it "bigger body" $ [("123", "1", "SEND 4\nhello\n")] >#> [("", "1", "ERROR SYNTAX 7")] - describe "broker response not allowed" do - it "OK" $ [("123", "1", "OK")] >#> [("", "1", "ERROR PROHIBITED")] + describe "SMP syntax" syntaxTests + fdescribe "SMP connections" connectionTests -noParamsSyntaxTest :: String -> SpecWith () -noParamsSyntaxTest cmd = describe cmd do - it "valid syntax" $ [("123", "1", cmd)] >#> [("", "1", "ERROR AUTH")] - it "parameters" $ [("123", "1", cmd ++ " 1")] >#> [("", "1", "ERROR SYNTAX 2")] - it "no signature" $ [("", "1", cmd)] >#> [("", "1", "ERROR SYNTAX 3")] - it "no connection ID" $ [("123", "", cmd)] >#> [("", "", "ERROR SYNTAX 3")] +pattern Resp :: ConnId -> Command 'Broker -> TransmissionOrError +pattern Resp connId command = ("", (connId, Right (Cmd SBroker command))) -oneParamSyntaxTest :: String -> SpecWith () -oneParamSyntaxTest cmd = describe cmd do - it "valid syntax" $ [("123", "1", cmd ++ " 456")] >#> [("", "1", "ERROR AUTH")] - it "no parameters" $ [("123", "1", cmd)] >#> [("", "1", "ERROR SYNTAX 2")] - it "many parameters" $ [("123", "1", cmd ++ " 1 2")] >#> [("", "1", "ERROR SYNTAX 2")] - it "no signature" $ [("", "1", cmd ++ " 456")] >#> [("", "1", "ERROR SYNTAX 3")] - it "no connection ID" $ [("123", "", cmd ++ " 456")] >#> [("", "", "ERROR SYNTAX 3")] +smpExpect :: (Show a, Eq a) => a -> (Handle -> IO a) -> Expectation +smpExpect result test = runSmpTest test `shouldReturn` result + +sendRecv :: Handle -> RawTransmission -> IO TransmissionOrError +sendRecv h t = tPutRaw h t >> tGet fromServer h + +connectionTests :: SpecWith () +connectionTests = do + it "CREATE and SECURE connection, SEND messages (no delivery yet)" $ + smpExpect True \h -> do + Resp rId (CONN rId' sId) <- sendRecv h ("", "", "CREATE 123") + -- should allow unsigned + Resp sId' OK <- sendRecv h ("", sId, "SEND :hello") + -- should not allow signed + Resp sId'' (ERROR AUTH) <- sendRecv h ("456", sId, "SEND :hello") + -- shoud not secure with wrong signature (password atm) + Resp _ (ERROR AUTH) <- sendRecv h ("1234", rId, "SECURE 456") + -- shoud not secure with sender's ID + Resp _ (ERROR AUTH) <- sendRecv h ("123", sId, "SECURE 456") + -- secure connection + Resp rId'' OK <- sendRecv h ("123", rId, "SECURE 456") + -- should not secure if already secured + Resp _ (ERROR AUTH) <- sendRecv h ("123", rId, "SECURE 456") + -- should allow signed + Resp _ OK <- sendRecv h ("456", sId, "SEND :hello") + -- should not allow unsigned + Resp _ (ERROR AUTH) <- sendRecv h ("", sId, "SEND :hello") + return $ rId == rId' && rId == rId'' && sId == sId' && sId == sId'' + +syntaxTests :: SpecWith () +syntaxTests = do + it "unknown command" $ [("", "123", "HELLO")] >#> [("", "123", "ERROR UNKNOWN")] + describe "CREATE" do + it "no parameters" $ [("", "", "CREATE")] >#> [("", "", "ERROR SYNTAX 2")] + it "many parameters" $ [("", "", "CREATE 1 2")] >#> [("", "", "ERROR SYNTAX 2")] + it "has signature" $ [("123", "", "CREATE 123")] >#> [("", "", "ERROR SYNTAX 4")] + it "connection ID" $ [("", "1", "CREATE 123")] >#> [("", "1", "ERROR SYNTAX 4")] + noParamsSyntaxTest "SUB" + oneParamSyntaxTest "SECURE" + oneParamSyntaxTest "DELMSG" + noParamsSyntaxTest "SUSPEND" + noParamsSyntaxTest "DELETE" + describe "SEND" do + it "valid syntax 1" $ [("123", "1", "SEND :hello")] >#> [("", "1", "ERROR AUTH")] + it "valid syntax 2" $ [("123", "1", "SEND 11\nhello there\n")] >#> [("", "1", "ERROR AUTH")] + it "no parameters" $ [("123", "1", "SEND")] >#> [("", "1", "ERROR SYNTAX 2")] + it "many parameters" $ [("123", "1", "SEND 11 hello")] >#> [("", "1", "ERROR SYNTAX 2")] + it "no connection ID" $ [("123", "", "SEND :hello")] >#> [("", "", "ERROR SYNTAX 5")] + it "bad message body" $ [("123", "1", "SEND hello")] >#> [("", "1", "ERROR SYNTAX 6")] + it "bigger body" $ [("123", "1", "SEND 4\nhello\n")] >#> [("", "1", "ERROR SYNTAX 7")] + describe "broker response not allowed" do + it "OK" $ [("123", "1", "OK")] >#> [("", "1", "ERROR PROHIBITED")] + where + noParamsSyntaxTest :: String -> SpecWith () + noParamsSyntaxTest cmd = describe cmd do + it "valid syntax" $ [("123", "1", cmd)] >#> [("", "1", "ERROR AUTH")] + it "parameters" $ [("123", "1", cmd ++ " 1")] >#> [("", "1", "ERROR SYNTAX 2")] + it "no signature" $ [("", "1", cmd)] >#> [("", "1", "ERROR SYNTAX 3")] + it "no connection ID" $ [("123", "", cmd)] >#> [("", "", "ERROR SYNTAX 3")] + + oneParamSyntaxTest :: String -> SpecWith () + oneParamSyntaxTest cmd = describe cmd do + it "valid syntax" $ [("123", "1", cmd ++ " 456")] >#> [("", "1", "ERROR AUTH")] + it "no parameters" $ [("123", "1", cmd)] >#> [("", "1", "ERROR SYNTAX 2")] + it "many parameters" $ [("123", "1", cmd ++ " 1 2")] >#> [("", "1", "ERROR SYNTAX 2")] + it "no signature" $ [("", "1", cmd ++ " 456")] >#> [("", "1", "ERROR SYNTAX 3")] + it "no connection ID" $ [("123", "", cmd ++ " 456")] >#> [("", "", "ERROR SYNTAX 3")]