From fbf17d34846c40dc4cf844690e56d8e1d0ab5955 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 14 Oct 2020 14:09:09 +0100
Subject: [PATCH] verify SEND command, refactor

---
 src/Server.hs    | 40 ++++++++++++++++++++--------------------
 src/Transport.hs |  2 +-
 tests/Test.hs    |  4 ++--
 3 files changed, 23 insertions(+), 23 deletions(-)

diff --git a/src/Server.hs b/src/Server.hs
index 8b51874b4..8e49354f3 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -3,7 +3,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -14,6 +14,7 @@ import ConnStore
 import Control.Monad
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
+import Data.Singletons
 import Env.STM
 import Network.Socket
 import Transmission
@@ -54,28 +55,27 @@ receive Client {handle, channel} = forever $ do
 
 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
+  (connId,) <$> case cmd of
+    Cmd SBroker _ -> return $ smpErr INTERNAL
     Cmd SRecipient (CREATE _) -> return cmd
-    Cmd SSender (SEND _) -> return cmd -- TODO verify sender's signature for secured connections
-    Cmd _ _ -> verifyConnSignature cmd
-  return (connId, cmd')
+    Cmd SRecipient _ -> withConnection SRecipient $ verifySignature . recipientKey
+    Cmd SSender (SEND _) -> withConnection SSender $ verifySend . senderKey
   where
-    verifyConnSignature :: Cmd -> m Cmd
-    verifyConnSignature c@(Cmd party _) = do
+    smpErr e = Cmd SBroker $ ERROR e
+    authErr = smpErr AUTH
+    withConnection :: Sing (p :: Party) -> (Connection -> m Cmd) -> m Cmd
+    withConnection party f = do
       store <- asks connStore
-      getConn store party connId >>= \case
-        Right Connection {recipientKey, senderKey} -> do
-          res <- case party of
-            SRecipient -> verifySignature recipientKey
-            SSender -> case senderKey of
-              Just key -> verifySignature key
-              Nothing -> return False
-            SBroker -> return False
-          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
+      conn <- getConn store party connId
+      either (return . smpErr) f conn
+    verifySend :: Maybe PublicKey -> m Cmd
+    verifySend =
+      if null signature
+        then return . maybe cmd (const authErr)
+        else maybe (return authErr) verifySignature
+    -- TODO stub
+    verifySignature :: PublicKey -> m Cmd
+    verifySignature key = return $ if signature == key then cmd else authErr
 
 client :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
 client Client {handle, channel} = loop
diff --git a/src/Transport.hs b/src/Transport.hs
index 0dee04fa5..6566f99b4 100644
--- a/src/Transport.hs
+++ b/src/Transport.hs
@@ -103,7 +103,7 @@ tGet fromParty h = do
         if null connId
           then Left $ SYNTAX errNoConnectionId
           else Right cmd
-      -- other client commands must have both signature and connectio ID
+      -- other client commands must have both signature and connection ID
       _ ->
         if null signature || null connId
           then Left $ SYNTAX errNoCredentials
diff --git a/tests/Test.hs b/tests/Test.hs
index 629876254..c492314ab 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -21,8 +21,8 @@ main = hspec do
     noParamsSyntaxTest "SUSPEND"
     noParamsSyntaxTest "DELETE"
     describe "SEND" do
-      it "valid syntax 1" $ [("123", "1", "SEND :hello")] >#> [("", "1", "OK")]
-      it "valid syntax 2" $ [("123", "1", "SEND 11\nhello there\n")] >#> [("", "1", "OK")]
+      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")]