From 3f72f19b68622d7fbe6840507d6dc5e2f950e8d6 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 12 Oct 2020 21:48:35 +0100 Subject: [PATCH] more syntax validation, read full SEND msgBody --- src/{Store.hs => ConnStore.hs} | 8 ++-- src/EnvStm.hs | 2 +- src/Main.hs | 68 +++++++++++++++++--------------- src/Transmission.hs | 71 ++++++++++++++++++++++++++-------- src/Transport.hs | 5 +++ 5 files changed, 101 insertions(+), 53 deletions(-) rename src/{Store.hs => ConnStore.hs} (92%) diff --git a/src/Store.hs b/src/ConnStore.hs similarity index 92% rename from src/Store.hs rename to src/ConnStore.hs index 52d6af751..e6825de54 100644 --- a/src/Store.hs +++ b/src/ConnStore.hs @@ -10,7 +10,7 @@ -- {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Store where +module ConnStore where import Control.Concurrent.STM import Data.Map (Map) @@ -74,12 +74,12 @@ runConnStoreSTM = reinterpret $ \case return $ Right conn GetConn Recipient rId -> do db <- input >>= embed . readTVar - return $ getConn db rId + return $ getRcpConn db rId GetConn Sender sId -> do db <- input >>= embed . readTVar - return $ maybeError (getConn db) $ M.lookup sId $ senders db + return $ maybeError (getRcpConn db) $ M.lookup sId $ senders db GetConn Broker _ -> do return $ Left InternalError where maybeError = maybe (Left AuthError) - getConn db rId = maybeError Right $ M.lookup rId $ connections db + getRcpConn db rId = maybeError Right $ M.lookup rId $ connections db diff --git a/src/EnvStm.hs b/src/EnvStm.hs index 6b8965797..76bc8fe06 100644 --- a/src/EnvStm.hs +++ b/src/EnvStm.hs @@ -3,11 +3,11 @@ module EnvSTM where +import ConnStore import Control.Concurrent.STM import qualified Data.Map as M import qualified Data.Set as S import Network.Socket (ServiceName) -import Store import System.IO import Transmission diff --git a/src/Main.hs b/src/Main.hs index ce5dd65c8..5f4b76aa2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,13 +8,15 @@ module Main where +-- import Polysemy +import ConnStore import Control.Monad import Control.Monad.IO.Unlift import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B import EnvSTM import Network.Socket --- import Polysemy -import Store +import Text.Read import Transmission import Transport import UnliftIO.Async @@ -44,38 +46,41 @@ runClient h = do c <- atomically $ newClient h void $ race (client c) (receive c) -receive :: MonadIO m => Client -> m () +receive :: MonadUnliftIO m => Client -> m () receive Client {handle, channel} = forever $ do signature <- getLn handle connId <- getLn handle command <- getLn handle - cmdOrError <- parseVerifyTransmission signature connId command + cmdOrError <- parseReadVerifyTransmission handle signature connId command atomically $ writeTChan channel cmdOrError -parseVerifyTransmission :: Monad m => String -> String -> String -> m SomeSigned -parseVerifyTransmission _ connId command = do - return (Just connId, parseCommand command) - -parseCommand :: String -> SomeCom -parseCommand command = case words command of - ["CREATE", recipientKey] -> rCmd $ CREATE recipientKey - ["SUB"] -> rCmd SUB - ["SECURE", senderKey] -> rCmd $ SECURE senderKey - ["DELMSG", msgId] -> rCmd $ DELMSG msgId - ["SUSPEND"] -> rCmd SUSPEND - ["DELETE"] -> rCmd DELETE - ["SEND", msgBody] -> SomeCom SSender $ SEND msgBody - "CREATE" : _ -> err SYNTAX - "SUB" : _ -> err SYNTAX - "SECURE" : _ -> err SYNTAX - "DELMSG" : _ -> err SYNTAX - "SUSPEND" : _ -> err SYNTAX - "DELETE" : _ -> err SYNTAX - "SEND" : _ -> err SYNTAX - _ -> err CMD - where - rCmd = SomeCom SRecipient - err t = SomeCom SBroker $ ERROR t +parseReadVerifyTransmission :: MonadUnliftIO m => Handle -> String -> String -> String -> m SomeSigned +parseReadVerifyTransmission h signature connId command = do + let cmd = parseCommand command + cmd' <- case cmd of + Cmd SBroker _ -> return cmd + Cmd _ (CREATE _) -> + return + if signature == "" && connId == "" + then cmd + else smpError SYNTAX + Cmd _ (SEND msgBody) -> + if connId == "" + then return $ smpError SYNTAX + 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 s == "" then smpSend body else smpError SYNTAX + Nothing -> return $ smpError SYNTAX + Cmd _ _ -> + return + if signature == "" || connId == "" + then smpError SYNTAX + else cmd + return (Just connId, cmd') client :: MonadIO m => Client -> m () client Client {handle, channel} = loop @@ -83,8 +88,9 @@ client Client {handle, channel} = loop loop = forever $ do (_, cmdOrErr) <- atomically $ readTChan channel let response = case cmdOrErr of - SomeCom SRecipient _ -> "OK" - SomeCom SSender _ -> "OK" - SomeCom SBroker (ERROR t) -> "ERROR " ++ show t + Cmd SRecipient _ -> "OK" + Cmd SSender _ -> "OK" + Cmd SBroker (ERROR t) -> "ERROR " ++ show t _ -> "ERROR INTERNAL" putLn handle response + liftIO $ print cmdOrErr diff --git a/src/Transmission.hs b/src/Transmission.hs index f3ae76f10..318e38d7f 100644 --- a/src/Transmission.hs +++ b/src/Transmission.hs @@ -1,40 +1,77 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Transmission where +import qualified Data.ByteString.Char8 as B import Data.Singletons.TH $( singletons [d| data Party = Broker | Recipient | Sender + deriving (Show) |] ) type Transmission (a :: Party) = (Signed a, Maybe Signature) -type Signed (a :: Party) = (Maybe ConnId, Com a) +type Signed (a :: Party) = (Maybe ConnId, Command a) -data SomeCom where - SomeCom :: Sing a -> Com a -> SomeCom +data Cmd where + Cmd :: Sing a -> Command a -> Cmd -type SomeSigned = (Maybe ConnId, SomeCom) +deriving instance Show Cmd -data Com (a :: Party) where - CREATE :: RecipientKey -> Com Recipient - SECURE :: SenderKey -> Com Recipient - DELMSG :: MsgId -> Com Recipient - SUB :: Com Recipient - SUSPEND :: Com Recipient - DELETE :: Com Recipient - SEND :: MsgBody -> Com Sender - MSG :: MsgId -> Timestamp -> MsgBody -> Com Broker - CONN :: SenderId -> RecipientId -> Com Broker - ERROR :: ErrorType -> Com Broker - OK :: Com Broker +type SomeSigned = (Maybe ConnId, Cmd) + +data Command (a :: Party) where + CREATE :: RecipientKey -> Command Recipient + SECURE :: SenderKey -> Command Recipient + DELMSG :: MsgId -> Command Recipient + SUB :: Command Recipient + SUSPEND :: Command Recipient + DELETE :: Command Recipient + SEND :: MsgBody -> Command Sender + MSG :: MsgId -> Timestamp -> MsgBody -> Command Broker + CONN :: SenderId -> RecipientId -> Command Broker + ERROR :: ErrorType -> Command Broker + OK :: Command Broker + +deriving instance Show (Command a) + +parseCommand :: String -> Cmd +parseCommand command = case words command of + ["CREATE", recipientKey] -> rCmd $ CREATE recipientKey + ["SUB"] -> rCmd SUB + ["SECURE", senderKey] -> rCmd $ SECURE senderKey + ["DELMSG", msgId] -> rCmd $ DELMSG msgId + ["SUSPEND"] -> rCmd SUSPEND + ["DELETE"] -> rCmd DELETE + ["SEND", msgBody] -> smpSend $ B.pack msgBody + "CREATE" : _ -> smpError SYNTAX + "SUB" : _ -> smpError SYNTAX + "SECURE" : _ -> smpError SYNTAX + "DELMSG" : _ -> smpError SYNTAX + "SUSPEND" : _ -> smpError SYNTAX + "DELETE" : _ -> smpError SYNTAX + "SEND" : _ -> smpError SYNTAX + _ -> smpError CMD + where + rCmd = Cmd SRecipient + +smpError :: ErrorType -> Cmd +smpError = Cmd SBroker . ERROR + +smpSend :: MsgBody -> Cmd +smpSend = Cmd SSender . SEND type Encoded = String @@ -56,6 +93,6 @@ type MsgId = Encoded type Timestamp = Encoded -type MsgBody = Encoded +type MsgBody = B.ByteString data ErrorType = CMD | SYNTAX | AUTH | INTERNAL deriving (Show) diff --git a/src/Transport.hs b/src/Transport.hs index 9748d9a4b..244b6f8d2 100644 --- a/src/Transport.hs +++ b/src/Transport.hs @@ -3,7 +3,9 @@ module Transport where import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B import EnvSTM import Network.Socket import System.IO @@ -36,3 +38,6 @@ putLn h = liftIO . hPutStrLn h getLn :: MonadIO m => Handle -> m String getLn = liftIO . hGetLine + +getBytes :: MonadUnliftIO m => Handle -> Int -> m B.ByteString +getBytes h = liftIO . B.hGet h