add error types

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)

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
 

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

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

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