diff --git a/src/Server.hs b/src/Server.hs index 09dde99e0..16c0cf5a6 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -5,6 +5,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -16,8 +17,7 @@ import Control.Monad import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random -import Data.ByteString (ByteString) -import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Map.Strict as M import Data.Singletons @@ -79,7 +79,7 @@ receive h Client {rcvQ} = forever $ do send :: MonadUnliftIO m => Handle -> Client -> m () send h Client {sndQ} = forever $ do signed <- atomically $ readTBQueue sndQ - tPut h ("", signed) + tPut h (B.empty, signed) verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => Signature -> ConnId -> Cmd -> m Signed verifyTransmission signature connId cmd = do @@ -96,7 +96,7 @@ verifyTransmission signature connId cmd = do either (return . smpErr) f conn verifySend :: Maybe PublicKey -> m Cmd verifySend - | null signature = return . maybe cmd (const authErr) + | B.null signature = return . maybe cmd (const authErr) | otherwise = maybe (return authErr) verifySignature -- TODO stub verifySignature :: PublicKey -> m Cmd @@ -134,7 +134,7 @@ client clnt@Client {connections, rcvQ, sndQ} Server {subscribedQ} = okResponse = mkSigned connId . either ERR (const OK) createConn :: MonadConnStore s m => s -> RecipientKey -> m Signed - createConn st rKey = mkSigned "" <$> addSubscribe + createConn st rKey = mkSigned B.empty <$> addSubscribe where addSubscribe = do addConn st getIds rKey >>= \case @@ -210,7 +210,7 @@ client clnt@Client {connections, rcvQ, sndQ} Server {subscribedQ} = randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m Encoded randomId n = do gVar <- asks idsDrg - B.unpack . encode <$> atomically (randomBytes n gVar) + atomically (randomBytes n gVar) randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString randomBytes n gVar = do diff --git a/src/Transmission.hs b/src/Transmission.hs index 6ae7786a1..6be1860fa 100644 --- a/src/Transmission.hs +++ b/src/Transmission.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -12,11 +13,13 @@ module Transmission where +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Char (ord) import Data.Singletons.TH import Data.Time.Clock import Data.Time.ISO8601 -import Text.Read $( singletons [d| @@ -38,7 +41,7 @@ type SignedOrError = (ConnId, Either ErrorType Cmd) type TransmissionOrError = (Signature, SignedOrError) -type RawTransmission = (String, String, String) +type RawTransmission = (ByteString, ByteString, ByteString) data Command (a :: Party) where CONN :: RecipientKey -> Command Recipient @@ -58,26 +61,36 @@ deriving instance Show (Command a) deriving instance Eq (Command a) -parseCommand :: String -> Either ErrorType Cmd -parseCommand command = case words command of - ["CONN", recipientKey] -> rCmd $ CONN recipientKey +parseCommand :: ByteString -> Either ErrorType Cmd +parseCommand command = case B.words command of + ["CONN", rKeyStr] -> case decode rKeyStr of + Right rKey -> rCmd $ CONN rKey + _ -> errParams ["SUB"] -> rCmd SUB - ["KEY", senderKey] -> rCmd $ KEY senderKey + ["KEY", sKeyStr] -> case decode sKeyStr of + Right sKey -> rCmd $ KEY sKey + _ -> errParams ["ACK"] -> rCmd ACK ["OFF"] -> rCmd OFF ["DEL"] -> rCmd DEL ["SEND"] -> errParams - "SEND" : msgBody -> Right . Cmd SSender . SEND . B.pack $ unwords msgBody - ["IDS", rId, sId] -> bCmd $ IDS rId sId - ["MSG", msgId, ts, msgBody] -> case parseISO8601 ts of - Just utc -> bCmd $ MSG msgId utc (B.pack msgBody) + "SEND" : msgBody -> Right . Cmd SSender . SEND $ B.unwords msgBody + ["IDS", rIdStr, sIdStr] -> case decode rIdStr of + Right rId -> case decode sIdStr of + Right sId -> bCmd $ IDS rId sId + _ -> errParams + _ -> errParams + ["MSG", msgIdStr, ts, msgBody] -> case decode msgIdStr of + Right msgId -> case parseISO8601 $ B.unpack ts of + Just utc -> bCmd $ MSG msgId utc msgBody + _ -> errParams _ -> errParams ["END"] -> bCmd END ["OK"] -> bCmd OK "ERR" : err -> case err of ["UNKNOWN"] -> bErr UNKNOWN ["PROHIBITED"] -> bErr PROHIBITED - ["SYNTAX", errCode] -> maybe errParams (bErr . SYNTAX) $ readMaybe errCode + ["SYNTAX", errCode] -> maybe errParams (bErr . SYNTAX) $ digitToInt $ B.unpack errCode ["SIZE"] -> bErr SIZE ["AUTH"] -> bErr AUTH ["INTERNAL"] -> bErr INTERNAL @@ -99,21 +112,30 @@ parseCommand command = case words command of bCmd = Right . Cmd SBroker bErr = bCmd . ERR -serializeCommand :: Cmd -> String -serializeCommand = \case - Cmd SRecipient (CONN rKey) -> "CONN " ++ rKey - Cmd SRecipient (KEY sKey) -> "KEY " ++ sKey - Cmd SRecipient cmd -> show cmd - Cmd SSender (SEND msgBody) -> "SEND" ++ serializeMsg msgBody - Cmd SBroker (MSG msgId ts msgBody) -> - unwords ["MSG", msgId, formatISO8601Millis ts] ++ serializeMsg msgBody - Cmd SBroker (IDS rId sId) -> unwords ["IDS", rId, sId] - Cmd SBroker (ERR err) -> "ERR " ++ show err - Cmd SBroker resp -> show resp - where - serializeMsg msgBody = " " ++ show (B.length msgBody) ++ "\n" ++ B.unpack msgBody +digitToInt :: String -> Maybe Int +digitToInt [c] = + let i = ord c - zero + in if i >= 0 && i <= 9 then Just i else Nothing +digitToInt _ = Nothing -type Encoded = String +zero :: Int +zero = ord '0' + +serializeCommand :: Cmd -> ByteString +serializeCommand = \case + Cmd SRecipient (CONN rKey) -> "CONN " <> encode rKey + Cmd SRecipient (KEY sKey) -> "KEY " <> encode sKey + Cmd SRecipient cmd -> B.pack $ show cmd + Cmd SSender (SEND msgBody) -> "SEND" <> serializeMsg msgBody + Cmd SBroker (MSG msgId ts msgBody) -> + B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts] <> serializeMsg msgBody + Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId] + Cmd SBroker (ERR err) -> "ERR " <> B.pack (show err) + Cmd SBroker resp -> B.pack $ show resp + where + serializeMsg msgBody = " " <> B.pack (show $ B.length msgBody) <> "\n" <> msgBody + +type Encoded = ByteString type PublicKey = Encoded @@ -131,10 +153,13 @@ type ConnId = Encoded type MsgId = Encoded -type MsgBody = B.ByteString +type MsgBody = ByteString data ErrorType = UNKNOWN | PROHIBITED | SYNTAX Int | SIZE | AUTH | INTERNAL deriving (Show, Eq) +errBadTransmission :: Int +errBadTransmission = 1 + errBadParameters :: Int errBadParameters = 2 diff --git a/src/Transport.hs b/src/Transport.hs index 776af57cb..7953c3b48 100644 --- a/src/Transport.hs +++ b/src/Transport.hs @@ -10,6 +10,8 @@ module Transport where import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Reader +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Network.Socket import System.IO @@ -67,27 +69,29 @@ getSocketHandle conn = liftIO $ do hSetBuffering h LineBuffering return h -putLn :: MonadIO m => Handle -> String -> m () -putLn h = liftIO . hPutStrLn h +putLn :: MonadIO m => Handle -> ByteString -> m () +putLn h = liftIO . hPutStrLn h . B.unpack -getLn :: MonadIO m => Handle -> m String -getLn = liftIO . hGetLine +getLn :: MonadIO m => Handle -> m ByteString +getLn h = B.pack <$> liftIO (hGetLine h) -getBytes :: MonadIO m => Handle -> Int -> m B.ByteString +getBytes :: MonadIO m => Handle -> Int -> m ByteString getBytes h = liftIO . B.hGet h tPutRaw :: MonadIO m => Handle -> RawTransmission -> m () tPutRaw h (signature, connId, command) = do - putLn h signature - putLn h connId + putLn h (encode signature) + putLn h (encode connId) putLn h command -tGetRaw :: MonadIO m => Handle -> m RawTransmission -tGetRaw h = do - signature <- getLn h - connId <- getLn h - command <- getLn h - return (signature, connId, command) +tGetRaw :: MonadIO m => Handle -> m (Maybe RawTransmission) +tGetRaw h = + getDecodedLn $ \signature -> + getDecodedLn $ \connId -> do + command <- getLn h + return $ Just (signature, connId, command) + where + getDecodedLn f = getLn h >>= either (\_ -> return Nothing) f . decode tPut :: MonadIO m => Handle -> Transmission -> m () tPut h (signature, (connId, command)) = tPutRaw h (signature, connId, serializeCommand command) @@ -105,12 +109,17 @@ fromServer = \case -- | get client and server transmissions -- `fromParty` is used to limit allowed senders - `fromClient` or `fromServer` should be used tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> Handle -> m TransmissionOrError -tGet fromParty h = do - t@(signature, connId, command) <- tGetRaw h - let cmd = (parseCommand >=> fromParty) command >>= tCredentials t - fullCmd <- either (return . Left) cmdWithMsgBody cmd - return (signature, (connId, fullCmd)) +tGet fromParty h = tGetRaw h >>= maybe badTransmission tParseComplete where + badTransmission :: m TransmissionOrError + badTransmission = return (B.empty, (B.empty, Left $ SYNTAX errBadTransmission)) + + tParseComplete :: RawTransmission -> m TransmissionOrError + tParseComplete t@(signature, connId, command) = do + let cmd = parseCommand command >>= fromParty >>= tCredentials t + fullCmd <- either (return . Left) cmdWithMsgBody cmd + return (signature, (connId, fullCmd)) + tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd tCredentials (signature, connId, _) cmd = case cmd of -- IDS response should not have connection ID @@ -119,19 +128,19 @@ tGet fromParty h = do Cmd SBroker (ERR _) -> Right cmd -- other responses must have connection ID Cmd SBroker _ - | null connId -> Left $ SYNTAX errNoConnectionId + | B.null connId -> Left $ SYNTAX errNoConnectionId | otherwise -> Right cmd -- CREATE must NOT have signature or connection ID Cmd SRecipient (CONN _) - | null signature && null connId -> Right cmd + | B.null signature && B.null connId -> Right cmd | otherwise -> Left $ SYNTAX errHasCredentials -- SEND must have connection ID, signature is not always required Cmd SSender (SEND _) - | null connId -> Left $ SYNTAX errNoConnectionId + | B.null connId -> Left $ SYNTAX errNoConnectionId | otherwise -> Right cmd -- other client commands must have both signature and connection ID Cmd SRecipient _ - | null signature || null connId -> Left $ SYNTAX errNoCredentials + | B.null signature || B.null connId -> Left $ SYNTAX errNoCredentials | otherwise -> Right cmd cmdWithMsgBody :: Cmd -> m (Either ErrorType Cmd) @@ -154,5 +163,5 @@ tGet fromParty h = do Just size -> do body <- getBytes h size s <- getLn h - return if null s then Right body else Left SIZE + return if B.null s then Right body else Left SIZE Nothing -> return . Left $ SYNTAX errMessageBody diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index b347f068e..fda1a1343 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} module SMPClient where import Control.Monad.IO.Unlift import Crypto.Random +import Data.Maybe import Network.Socket import Numeric.Natural import Server @@ -31,8 +33,6 @@ testHost = "localhost" queueSize :: Natural queueSize = 2 -type TestTransmission = (Signature, ConnId, String) - runSmpTest :: (MonadUnliftIO m, MonadRandom m) => (Handle -> m a) -> m a runSmpTest test = E.bracket @@ -40,8 +40,8 @@ runSmpTest test = (liftIO . killThread) \_ -> testSMPClient "localhost" testPort test -smpServerTest :: [TestTransmission] -> IO [TestTransmission] +smpServerTest :: [RawTransmission] -> IO [RawTransmission] smpServerTest commands = runSmpTest \h -> mapM (sendReceive h) commands where - sendReceive :: Handle -> TestTransmission -> IO TestTransmission - sendReceive h t = tPutRaw h t >> tGetRaw h + sendReceive :: Handle -> RawTransmission -> IO RawTransmission + sendReceive h t = tPutRaw h t >> fromJust <$> tGetRaw h diff --git a/tests/Test.hs b/tests/Test.hs index 9244fc46c..371ab03e1 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -4,6 +4,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Either import SMPClient import System.IO (Handle) import Test.HUnit @@ -11,7 +15,7 @@ import Test.Hspec import Transmission import Transport -(>#>) :: [TestTransmission] -> [TestTransmission] -> Expectation +(>#>) :: [RawTransmission] -> [RawTransmission] -> Expectation commands >#> responses = smpServerTest commands `shouldReturn` responses main :: IO () @@ -28,16 +32,16 @@ smpTest :: (Handle -> IO ()) -> Expectation smpTest test' = runSmpTest test' `shouldReturn` () sendRecv :: Handle -> RawTransmission -> IO TransmissionOrError -sendRecv h t = tPutRaw h t >> tGet fromServer h +sendRecv h (sgn, cId, cmd) = tPutRaw h (fromRight "" $ decode sgn, cId, cmd) >> tGet fromServer h (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion (actual, expected) #== message = assertEqual message expected actual testCreateSecure :: SpecWith () testCreateSecure = do - it "CONN and KEY commands, SEND messages (no delivery yet)" $ + it "CONN and KEY commands, SEND messages" $ smpTest \h -> do - Resp rId1 (IDS rId sId) <- sendRecv h ("", "", "CONN 123") + Resp rId1 (IDS rId sId) <- sendRecv h ("", "", "CONN 1234") (rId1, "") #== "creates connection" Resp sId1 ok1 <- sendRecv h ("", sId, "SEND :hello") @@ -47,33 +51,33 @@ testCreateSecure = do Resp _ (MSG _ _ msg1) <- tGet fromServer h (msg1, "hello") #== "delivers message" - Resp _ ok4 <- sendRecv h ("123", rId, "ACK") + Resp _ ok4 <- sendRecv h ("1234", rId, "ACK") (ok4, OK) #== "replies OK when message acknowledged if no more messages" - Resp sId2 err1 <- sendRecv h ("456", sId, "SEND :hello") + Resp sId2 err1 <- sendRecv h ("4567", sId, "SEND :hello") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same connection ID in response 2" - Resp _ err2 <- sendRecv h ("1234", rId, "KEY 456") + Resp _ err2 <- sendRecv h ("12345678", rId, "KEY 4567") (err2, ERR AUTH) #== "rejects KEY with wrong signature (password atm)" - Resp _ err3 <- sendRecv h ("123", sId, "KEY 456") + Resp _ err3 <- sendRecv h ("1234", sId, "KEY 4567") (err3, ERR AUTH) #== "rejects KEY with sender's ID" - Resp rId2 ok2 <- sendRecv h ("123", rId, "KEY 456") + Resp rId2 ok2 <- sendRecv h ("1234", rId, "KEY 4567") (ok2, OK) #== "secures connection" (rId2, rId) #== "same connection ID in response 3" - Resp _ err4 <- sendRecv h ("123", rId, "KEY 456") + Resp _ err4 <- sendRecv h ("1234", rId, "KEY 4567") (err4, ERR AUTH) #== "rejects KEY if already secured" - Resp _ ok3 <- sendRecv h ("456", sId, "SEND 11\nhello again") + Resp _ ok3 <- sendRecv h ("4567", sId, "SEND 11\nhello again") (ok3, OK) #== "accepts signed SEND" Resp _ (MSG _ _ msg) <- tGet fromServer h (msg, "hello again") #== "delivers message 2" - Resp _ ok5 <- sendRecv h ("123", rId, "ACK") + Resp _ ok5 <- sendRecv h ("1234", rId, "ACK") (ok5, OK) #== "replies OK when message acknowledged 2" Resp _ err5 <- sendRecv h ("", sId, "SEND :hello") @@ -81,96 +85,96 @@ testCreateSecure = do testCreateDelete :: SpecWith () testCreateDelete = do - it "CONN, OFF and DEL commands, SEND messages (no delivery yet)" $ + it "CONN, OFF and DEL commands, SEND messages" $ smpTest \h -> do - Resp rId1 (IDS rId sId) <- sendRecv h ("", "", "CONN 123") + Resp rId1 (IDS rId sId) <- sendRecv h ("", "", "CONN 1234") (rId1, "") #== "creates connection" - Resp _ ok1 <- sendRecv h ("123", rId, "KEY 456") + Resp _ ok1 <- sendRecv h ("1234", rId, "KEY 4567") (ok1, OK) #== "secures connection" - Resp _ ok2 <- sendRecv h ("456", sId, "SEND :hello") + Resp _ ok2 <- sendRecv h ("4567", sId, "SEND :hello") (ok2, OK) #== "accepts signed SEND" Resp _ (MSG _ _ msg1) <- tGet fromServer h (msg1, "hello") #== "delivers message" - Resp _ err1 <- sendRecv h ("1234", rId, "OFF") + Resp _ err1 <- sendRecv h ("12345678", rId, "OFF") (err1, ERR AUTH) #== "rejects OFF with wrong signature (password atm)" - Resp _ err2 <- sendRecv h ("123", sId, "OFF") + Resp _ err2 <- sendRecv h ("1234", sId, "OFF") (err2, ERR AUTH) #== "rejects OFF with sender's ID" - Resp rId2 ok3 <- sendRecv h ("123", rId, "OFF") + Resp rId2 ok3 <- sendRecv h ("1234", rId, "OFF") (ok3, OK) #== "suspends connection" (rId2, rId) #== "same connection ID in response 2" - Resp _ err3 <- sendRecv h ("456", sId, "SEND :hello") + Resp _ err3 <- sendRecv h ("4567", sId, "SEND :hello") (err3, ERR AUTH) #== "rejects signed SEND" Resp _ err4 <- sendRecv h ("", sId, "SEND :hello") (err4, ERR AUTH) #== "reject unsigned SEND too" - Resp _ ok4 <- sendRecv h ("123", rId, "OFF") + Resp _ ok4 <- sendRecv h ("1234", rId, "OFF") (ok4, OK) #== "accepts OFF when suspended" - Resp _ (MSG _ _ msg) <- sendRecv h ("123", rId, "SUB") + Resp _ (MSG _ _ msg) <- sendRecv h ("1234", rId, "SUB") (msg, "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)" - Resp _ err5 <- sendRecv h ("1234", rId, "DEL") + Resp _ err5 <- sendRecv h ("12345678", rId, "DEL") (err5, ERR AUTH) #== "rejects DEL with wrong signature (password atm)" - Resp _ err6 <- sendRecv h ("123", sId, "DEL") + Resp _ err6 <- sendRecv h ("1234", sId, "DEL") (err6, ERR AUTH) #== "rejects DEL with sender's ID" - Resp rId3 ok6 <- sendRecv h ("123", rId, "DEL") + Resp rId3 ok6 <- sendRecv h ("1234", rId, "DEL") (ok6, OK) #== "deletes connection" (rId3, rId) #== "same connection ID in response 3" - Resp _ err7 <- sendRecv h ("456", sId, "SEND :hello") + Resp _ err7 <- sendRecv h ("4567", sId, "SEND :hello") (err7, ERR AUTH) #== "rejects signed SEND when deleted" Resp _ err8 <- sendRecv h ("", sId, "SEND :hello") (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted" - Resp _ err9 <- sendRecv h ("123", rId, "OFF") + Resp _ err9 <- sendRecv h ("1234", rId, "OFF") (err9, ERR AUTH) #== "rejects OFF when deleted" - Resp _ err10 <- sendRecv h ("123", rId, "SUB") + Resp _ err10 <- sendRecv h ("1234", rId, "SUB") (err10, ERR AUTH) #== "rejects SUB when deleted" syntaxTests :: SpecWith () syntaxTests = do - it "unknown command" $ [("", "123", "HELLO")] >#> [("", "123", "ERR UNKNOWN")] + it "unknown command" $ [("", "1234", "HELLO")] >#> [("", "1234", "ERR UNKNOWN")] describe "CONN" do it "no parameters" $ [("", "", "CONN")] >#> [("", "", "ERR SYNTAX 2")] it "many parameters" $ [("", "", "CONN 1 2")] >#> [("", "", "ERR SYNTAX 2")] - it "has signature" $ [("123", "", "CONN 123")] >#> [("", "", "ERR SYNTAX 4")] - it "connection ID" $ [("", "1", "CONN 123")] >#> [("", "1", "ERR SYNTAX 4")] + it "has signature" $ [("1234", "", "CONN 1234")] >#> [("", "", "ERR SYNTAX 4")] + it "connection ID" $ [("", "1", "CONN 1234")] >#> [("", "1", "ERR SYNTAX 4")] describe "KEY" do - it "valid syntax" $ [("123", "1", "KEY 456")] >#> [("", "1", "ERR AUTH")] - it "no parameters" $ [("123", "1", "KEY")] >#> [("", "1", "ERR SYNTAX 2")] - it "many parameters" $ [("123", "1", "KEY 1 2")] >#> [("", "1", "ERR SYNTAX 2")] - it "no signature" $ [("", "1", "KEY 456")] >#> [("", "1", "ERR SYNTAX 3")] - it "no connection ID" $ [("123", "", "KEY 456")] >#> [("", "", "ERR SYNTAX 3")] + it "valid syntax" $ [("1234", "1", "KEY 4567")] >#> [("", "1", "ERR AUTH")] + it "no parameters" $ [("1234", "1", "KEY")] >#> [("", "1", "ERR SYNTAX 2")] + it "many parameters" $ [("1234", "1", "KEY 1 2")] >#> [("", "1", "ERR SYNTAX 2")] + it "no signature" $ [("", "1", "KEY 4567")] >#> [("", "1", "ERR SYNTAX 3")] + it "no connection ID" $ [("1234", "", "KEY 4567")] >#> [("", "", "ERR SYNTAX 3")] noParamsSyntaxTest "SUB" noParamsSyntaxTest "ACK" noParamsSyntaxTest "OFF" noParamsSyntaxTest "DEL" describe "SEND" do - it "valid syntax 1" $ [("123", "1", "SEND :hello")] >#> [("", "1", "ERR AUTH")] - it "valid syntax 2" $ [("123", "1", "SEND 11\nhello there\n")] >#> [("", "1", "ERR AUTH")] - it "no parameters" $ [("123", "1", "SEND")] >#> [("", "1", "ERR SYNTAX 2")] - it "no connection ID" $ [("123", "", "SEND :hello")] >#> [("", "", "ERR SYNTAX 5")] - it "bad message body 1" $ [("123", "1", "SEND 11 hello")] >#> [("", "1", "ERR SYNTAX 6")] - it "bad message body 2" $ [("123", "1", "SEND hello")] >#> [("", "1", "ERR SYNTAX 6")] - it "bigger body" $ [("123", "1", "SEND 4\nhello\n")] >#> [("", "1", "ERR SIZE")] + it "valid syntax 1" $ [("1234", "1", "SEND :hello")] >#> [("", "1", "ERR AUTH")] + it "valid syntax 2" $ [("1234", "1", "SEND 11\nhello there\n")] >#> [("", "1", "ERR AUTH")] + it "no parameters" $ [("1234", "1", "SEND")] >#> [("", "1", "ERR SYNTAX 2")] + it "no connection ID" $ [("1234", "", "SEND :hello")] >#> [("", "", "ERR SYNTAX 5")] + it "bad message body 1" $ [("1234", "1", "SEND 11 hello")] >#> [("", "1", "ERR SYNTAX 6")] + it "bad message body 2" $ [("1234", "1", "SEND hello")] >#> [("", "1", "ERR SYNTAX 6")] + it "bigger body" $ [("1234", "1", "SEND 4\nhello\n")] >#> [("", "1", "ERR SIZE")] describe "broker response not allowed" do - it "OK" $ [("123", "1", "OK")] >#> [("", "1", "ERR PROHIBITED")] + it "OK" $ [("1234", "1", "OK")] >#> [("", "1", "ERR PROHIBITED")] where - noParamsSyntaxTest :: String -> SpecWith () - noParamsSyntaxTest cmd = describe cmd do - it "valid syntax" $ [("123", "1", cmd)] >#> [("", "1", "ERR AUTH")] - it "parameters" $ [("123", "1", cmd ++ " 1")] >#> [("", "1", "ERR SYNTAX 2")] + noParamsSyntaxTest :: ByteString -> SpecWith () + noParamsSyntaxTest cmd = describe (B.unpack cmd) do + it "valid syntax" $ [("1234", "1", cmd)] >#> [("", "1", "ERR AUTH")] + it "parameters" $ [("1234", "1", cmd <> " 1")] >#> [("", "1", "ERR SYNTAX 2")] it "no signature" $ [("", "1", cmd)] >#> [("", "1", "ERR SYNTAX 3")] - it "no connection ID" $ [("123", "", cmd)] >#> [("", "", "ERR SYNTAX 3")] + it "no connection ID" $ [("1234", "", cmd)] >#> [("", "", "ERR SYNTAX 3")]