mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
refactor: separate transmission syntax verification from signature verification
This commit is contained in:
Evgeny Poberezkin
+1
-1
@@ -40,7 +40,7 @@ tests:
|
||||
|
||||
ghc-options:
|
||||
# - -haddock
|
||||
# - -O2
|
||||
- -O0
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Werror=incomplete-patterns
|
||||
|
||||
+23
-50
@@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Server (runSMPServer) where
|
||||
|
||||
@@ -13,10 +14,8 @@ import ConnStore
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Env.STM
|
||||
import Network.Socket
|
||||
import Text.Read
|
||||
import Transmission
|
||||
import Transport
|
||||
import UnliftIO.Async
|
||||
@@ -44,59 +43,33 @@ runClient h = do
|
||||
|
||||
receive :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
|
||||
receive Client {handle, channel} = forever $ do
|
||||
signature <- getLn handle
|
||||
connId <- getLn handle
|
||||
command <- getLn handle
|
||||
cmdOrError <- parseReadVerifyTransmission handle signature connId command
|
||||
atomically $ writeTChan channel cmdOrError
|
||||
(signature, (connId, cmdOrError)) <- tGet fromClient handle
|
||||
-- TODO maybe send Either to queue?
|
||||
cmd <- either (return . (connId,) . Cmd SBroker . ERROR) (verifyTransmission handle signature connId) cmdOrError
|
||||
atomically $ writeTChan channel cmd
|
||||
|
||||
parseReadVerifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => Handle -> String -> String -> String -> m SomeSigned
|
||||
parseReadVerifyTransmission h signature connId command = do
|
||||
let cmd = case parseCommand command of
|
||||
Right (Cmd SBroker _) -> syntaxError errNotAllowed
|
||||
Right c -> c
|
||||
Left e -> smpError e
|
||||
verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => Handle -> Signature -> ConnId -> Cmd -> m SomeSigned
|
||||
verifyTransmission _h signature connId cmd = do
|
||||
cmd' <- case cmd of
|
||||
Cmd SBroker _ -> return cmd
|
||||
Cmd _ (CREATE _) -> signed False cmd errHasCredentials
|
||||
Cmd _ (SEND msgBody) -> getSendMsgBody msgBody
|
||||
Cmd _ _ -> verifyConnSignature cmd -- signed True cmd errNoCredentials
|
||||
Cmd SBroker _ -> return . Cmd SBroker $ ERROR 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')
|
||||
where
|
||||
signed :: Bool -> Cmd -> Int -> m Cmd
|
||||
signed isSigned cmd errCode =
|
||||
return
|
||||
if isSigned == (signature /= "") && isSigned == (connId /= "")
|
||||
then cmd
|
||||
else syntaxError errCode
|
||||
getSendMsgBody :: MsgBody -> m Cmd
|
||||
getSendMsgBody msgBody =
|
||||
if null connId
|
||||
then return $ syntaxError errNoConnectionId
|
||||
else case B.unpack msgBody of
|
||||
':' : body -> return . smpSend $ B.pack body
|
||||
sizeStr -> case readMaybe sizeStr :: Maybe Int of
|
||||
Just size -> do
|
||||
body <- getBytes h size
|
||||
s <- getLn h
|
||||
return if null s then smpSend body else syntaxError errMessageBodySize
|
||||
Nothing -> return $ syntaxError errMessageBody
|
||||
verifyConnSignature :: Cmd -> m Cmd
|
||||
verifyConnSignature cmd@(Cmd party _) =
|
||||
if null signature || null connId
|
||||
then return $ syntaxError errNoCredentials
|
||||
else 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 cmd else return $ smpError AUTH
|
||||
Left err -> return $ smpError err
|
||||
verifyConnSignature c@(Cmd party _) = 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 $ smpError AUTH
|
||||
Left err -> return $ smpError err
|
||||
verifySignature :: Encoded -> m Bool
|
||||
verifySignature key = return $ signature == key
|
||||
|
||||
|
||||
+8
-1
@@ -34,6 +34,10 @@ type SomeSigned = (ConnId, Cmd)
|
||||
|
||||
type Transmission = (Signature, SomeSigned)
|
||||
|
||||
type SomeSigned' = (ConnId, Either ErrorType Cmd)
|
||||
|
||||
type Transmission' = (Signature, SomeSigned')
|
||||
|
||||
type RawTransmission = (String, String, String)
|
||||
|
||||
data Command (a :: Party) where
|
||||
@@ -51,6 +55,9 @@ data Command (a :: Party) where
|
||||
|
||||
deriving instance Show (Command a)
|
||||
|
||||
mkTransmission :: Signature -> ConnId -> Either ErrorType Cmd -> Transmission'
|
||||
mkTransmission signature connId cmd = (signature, (connId, cmd))
|
||||
|
||||
parseCommand :: String -> Either ErrorType Cmd
|
||||
parseCommand command = case words command of
|
||||
["CREATE", recipientKey] -> rCmd $ CREATE recipientKey
|
||||
@@ -64,9 +71,9 @@ parseCommand command = case words command of
|
||||
["CONN", rId, sId] -> bCmd $ CONN rId sId
|
||||
["OK"] -> bCmd OK
|
||||
"ERROR" : err -> case err of
|
||||
["SYNTAX", errCode] -> maybe errParams (bCmd . ERROR . SYNTAX) $ readMaybe errCode
|
||||
["AUTH"] -> bCmd $ ERROR AUTH
|
||||
["INTERNAL"] -> bCmd $ ERROR INTERNAL
|
||||
["SYNTAX", errCode] -> maybe errParams (bCmd . ERROR . SYNTAX) $ readMaybe errCode
|
||||
_ -> errParams
|
||||
"CREATE" : _ -> errParams
|
||||
"SUB" : _ -> errParams
|
||||
|
||||
@@ -1,5 +1,9 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Transport where
|
||||
|
||||
@@ -9,6 +13,7 @@ import qualified Data.ByteString.Char8 as B
|
||||
import Env.STM
|
||||
import Network.Socket
|
||||
import System.IO
|
||||
import Text.Read
|
||||
import Transmission
|
||||
|
||||
startTCPServer :: (MonadReader Env m, MonadIO m) => m Socket
|
||||
@@ -59,3 +64,70 @@ tPutRaw h (signature, connId, command) = do
|
||||
putLn h signature
|
||||
putLn h connId
|
||||
putLn h command
|
||||
|
||||
fromClient :: Cmd -> Either ErrorType Cmd
|
||||
fromClient = \case
|
||||
Cmd SBroker _ -> Left $ SYNTAX errNotAllowed
|
||||
cmd -> Right cmd
|
||||
|
||||
fromServer :: Cmd -> Either ErrorType Cmd
|
||||
fromServer = \case
|
||||
cmd@(Cmd SBroker _) -> Right cmd
|
||||
_ -> Left $ SYNTAX errNotAllowed
|
||||
|
||||
-- | 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 fromParty h = do
|
||||
t@(signature, connId, command) <- tGetRaw h
|
||||
let cmd = (parseCommand >=> fromParty) command >>= tCredentials t
|
||||
fullCmd <- either (return . Left) cmdWithMsgBody cmd
|
||||
return $ mkTransmission signature connId fullCmd
|
||||
where
|
||||
tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
|
||||
tCredentials (signature, connId, _) cmd = case cmd of
|
||||
-- ERROR response does not always have connection ID
|
||||
Cmd SBroker (ERROR _) -> Right cmd
|
||||
-- other responses must have connection ID
|
||||
Cmd SBroker _ ->
|
||||
if null connId
|
||||
then Left $ SYNTAX errNoConnectionId
|
||||
else Right cmd
|
||||
-- CREATE must NOT have signature or connection ID
|
||||
Cmd SRecipient (CREATE _) ->
|
||||
if null signature && null connId
|
||||
then Right cmd
|
||||
else Left $ SYNTAX errHasCredentials
|
||||
-- SEND must have connection ID, signature is not always required
|
||||
Cmd SSender (SEND _) ->
|
||||
if null connId
|
||||
then Left $ SYNTAX errNoConnectionId
|
||||
else Right cmd
|
||||
-- other client commands must have both signature and connectio ID
|
||||
_ ->
|
||||
if null signature || null connId
|
||||
then Left $ SYNTAX errNoCredentials
|
||||
else Right cmd
|
||||
|
||||
cmdWithMsgBody :: Cmd -> m (Either ErrorType Cmd)
|
||||
cmdWithMsgBody = \case
|
||||
Cmd SSender (SEND body) ->
|
||||
Cmd SSender . SEND <$$> getMsgBody body
|
||||
Cmd SBroker (MSG msgId ts body) ->
|
||||
Cmd SBroker . MSG msgId ts <$$> getMsgBody body
|
||||
cmd -> return $ Right cmd
|
||||
|
||||
infixl 4 <$$>
|
||||
(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
|
||||
(<$$>) = fmap . fmap
|
||||
|
||||
getMsgBody :: MsgBody -> m (Either ErrorType MsgBody)
|
||||
getMsgBody msgBody =
|
||||
case B.unpack msgBody of
|
||||
':' : body -> return . Right $ B.pack body
|
||||
str -> case readMaybe str :: Maybe Int of
|
||||
Just size -> do
|
||||
body <- getBytes h size
|
||||
s <- getLn h
|
||||
return if null s then Right body else Left $ SYNTAX errMessageBodySize
|
||||
Nothing -> return . Left $ SYNTAX errMessageBody
|
||||
|
||||
Reference in New Issue
Block a user