diff --git a/src/Env/STM.hs b/src/Env/STM.hs index e8ce02ba1..a2d894bbf 100644 --- a/src/Env/STM.hs +++ b/src/Env/STM.hs @@ -25,7 +25,7 @@ data Server = Server data Client = Client { handle :: Handle, connections :: S.Set RecipientId, - channel :: TChan SomeSigned + channel :: TChan Signed } newServer :: STM (TVar Server) diff --git a/src/Server.hs b/src/Server.hs index 30976d7a9..8b51874b4 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -45,10 +45,14 @@ receive :: (MonadUnliftIO m, MonadReader Env m) => Client -> m () receive Client {handle, channel} = forever $ do (signature, (connId, cmdOrError)) <- tGet fromClient handle -- TODO maybe send Either to queue? - cmd <- either (return . (connId,) . Cmd SBroker . ERROR) (verifyTransmission handle signature connId) cmdOrError + cmd <- + either + (return . (connId,) . Cmd SBroker . ERROR) + (verifyTransmission handle signature connId) + cmdOrError atomically $ writeTChan channel cmd -verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => Handle -> Signature -> ConnId -> Cmd -> m SomeSigned +verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => Handle -> Signature -> ConnId -> Cmd -> m Signed verifyTransmission _h signature connId cmd = do cmd' <- case cmd of Cmd SBroker _ -> return . Cmd SBroker $ ERROR INTERNAL @@ -68,8 +72,8 @@ verifyTransmission _h signature connId cmd = do Just key -> verifySignature key Nothing -> return False SBroker -> return False - if res then return c else return $ smpError AUTH - Left err -> return $ smpError err + if res then return c else return . Cmd SBroker $ ERROR AUTH + Left err -> return . Cmd SBroker $ ERROR err verifySignature :: Encoded -> m Bool verifySignature key = return $ signature == key diff --git a/src/Transmission.hs b/src/Transmission.hs index 610aac0c8..f15b901ad 100644 --- a/src/Transmission.hs +++ b/src/Transmission.hs @@ -23,20 +23,16 @@ $( singletons |] ) -type Signed (a :: Party) = (ConnId, Command a) - data Cmd where Cmd :: Sing a -> Command a -> Cmd deriving instance Show Cmd -type SomeSigned = (ConnId, Cmd) +type Signed = (ConnId, Cmd) -type Transmission = (Signature, SomeSigned) +type SignedOrError = (ConnId, Either ErrorType Cmd) -type SomeSigned' = (ConnId, Either ErrorType Cmd) - -type Transmission' = (Signature, SomeSigned') +type Transmission = (Signature, SignedOrError) type RawTransmission = (String, String, String) @@ -55,7 +51,7 @@ data Command (a :: Party) where deriving instance Show (Command a) -mkTransmission :: Signature -> ConnId -> Either ErrorType Cmd -> Transmission' +mkTransmission :: Signature -> ConnId -> Either ErrorType Cmd -> Transmission mkTransmission signature connId cmd = (signature, (connId, cmd)) parseCommand :: String -> Either ErrorType Cmd @@ -66,7 +62,7 @@ parseCommand command = case words command of ["DELMSG", msgId] -> rCmd $ DELMSG msgId ["SUSPEND"] -> rCmd SUSPEND ["DELETE"] -> rCmd DELETE - ["SEND", msgBody] -> Right . smpSend $ B.pack msgBody + ["SEND", msgBody] -> Right . Cmd SSender . SEND $ B.pack msgBody ["MSG", msgId, timestamp, msgBody] -> bCmd $ MSG msgId timestamp (B.pack msgBody) ["CONN", rId, sId] -> bCmd $ CONN rId sId ["OK"] -> bCmd OK @@ -85,7 +81,7 @@ parseCommand command = case words command of "MSG" : _ -> errParams "CONN" : _ -> errParams "OK" : _ -> errParams - _ -> Left $ SYNTAX errUnknownCommand + _ -> Left UNKNOWN where errParams = Left $ SYNTAX errBadParameters rCmd = Right . Cmd SRecipient @@ -104,15 +100,6 @@ serializeCommand = \case Cmd SBroker (ERROR err) -> "ERROR " ++ show err Cmd SBroker OK -> "OK" -syntaxError :: Int -> Cmd -syntaxError err = smpError $ SYNTAX err - -smpError :: ErrorType -> Cmd -smpError errType = Cmd SBroker $ ERROR errType - -smpSend :: MsgBody -> Cmd -smpSend = Cmd SSender . SEND - type Encoded = String type PublicKey = Encoded @@ -135,10 +122,7 @@ type Timestamp = Encoded type MsgBody = B.ByteString -data ErrorType = SYNTAX Int | AUTH | INTERNAL deriving (Show) - -errUnknownCommand :: Int -errUnknownCommand = 1 +data ErrorType = UNKNOWN | PROHIBITED | SYNTAX Int | AUTH | INTERNAL deriving (Show) errBadParameters :: Int errBadParameters = 2 @@ -157,6 +141,3 @@ errMessageBody = 6 errMessageBodySize :: Int errMessageBodySize = 7 - -errNotAllowed :: Int -errNotAllowed = 8 diff --git a/src/Transport.hs b/src/Transport.hs index ea02ab914..0dee04fa5 100644 --- a/src/Transport.hs +++ b/src/Transport.hs @@ -67,17 +67,17 @@ tPutRaw h (signature, connId, command) = do fromClient :: Cmd -> Either ErrorType Cmd fromClient = \case - Cmd SBroker _ -> Left $ SYNTAX errNotAllowed + Cmd SBroker _ -> Left PROHIBITED cmd -> Right cmd fromServer :: Cmd -> Either ErrorType Cmd fromServer = \case cmd@(Cmd SBroker _) -> Right cmd - _ -> Left $ SYNTAX errNotAllowed + _ -> Left PROHIBITED -- | 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 Transmission' +tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> Handle -> m Transmission tGet fromParty h = do t@(signature, connId, command) <- tGetRaw h let cmd = (parseCommand >=> fromParty) command >>= tCredentials t diff --git a/tests/Test.hs b/tests/Test.hs index 291cee0e7..629876254 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -9,7 +9,7 @@ commands >#> responses = smpServerTest commands `shouldReturn` responses main :: IO () main = hspec do describe "SMP syntax" do - it "unknown command" $ [("", "123", "HELLO")] >#> [("", "123", "ERROR SYNTAX 1")] + 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")] @@ -29,7 +29,7 @@ main = hspec do 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 SYNTAX 8")] + it "OK" $ [("123", "1", "OK")] >#> [("", "1", "ERROR PROHIBITED")] noParamsSyntaxTest :: String -> SpecWith () noParamsSyntaxTest cmd = describe cmd do