From ce13ce11fc8941e83bfe3418f4b121b22eee017f Mon Sep 17 00:00:00 2001 From: Joscha Date: Sat, 27 Jan 2018 21:08:07 +0000 Subject: [PATCH] Clean up Types --- package.yaml | 2 + src/EuphApi/Threads.hs | 266 +++++++++++++++++++++++++++-------------- src/EuphApi/Types.hs | 19 ++- 3 files changed, 188 insertions(+), 99 deletions(-) diff --git a/package.yaml b/package.yaml index 433c117..d4a77db 100644 --- a/package.yaml +++ b/package.yaml @@ -24,12 +24,14 @@ dependencies: # basic stuff - time - text +- transformers # websocket connection - websockets - wuss # parsing json - aeson - bytestring +- unordered-containers # other - stm diff --git a/src/EuphApi/Threads.hs b/src/EuphApi/Threads.hs index 5dbef0b..2e79763 100644 --- a/src/EuphApi/Threads.hs +++ b/src/EuphApi/Threads.hs @@ -1,7 +1,61 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --- | Setup consisting of a few threads to send and receive packets to and from +-- | Setup consisting of a few threads to send and receive packets to and from -- the euphoria api using a websocket connection. +-- +-- @ +-- m: main thread +-- r: recvThread +-- f: fetchThread +-- s: sendThread +-- +-- On creation: +-- m: Create WS connection +-- m: Create channels +-- m: Start recvThread with all necessary info +-- r: Start fetchThread and sendThread using async +-- m: Return SendChan and EventChan +-- +-- On disconnect: +-- s: close connection (optional) +-- f: detect exception +-- f: RDisconnected -> RecvChan +-- f: *stops* +-- r: RecvChan -> RDisconnected +-- r: close SendChan +-- s: *stops* +-- r: wait for f and s to stop +-- r: clean up SendChan +-- r: clean up RecvChan +-- r: clean up response list +-- r: EventStopped -> EventChan +-- r: *stops* +-- -> All MVars are dealt with +-- +-- ↓ +-- │ +-- (SendChan) +-- │ +-- ┌─────────────────────╴│╶──────┐ +-- │ │ │ +-- │ (WS.Connection) │ │ +-- │ │ │ │ +-- │ [fetchThread] [sendThread] │ +-- │ │ │ │ +-- │ └──────┬──────┘ │ +-- │ │ │ +-- │ (RecvChan) │ +-- │ │ │ +-- │ [recvThread] │ +-- │ │ │ +-- └──────────────╴│╶─────────────┘ +-- │ +-- (EventChan) +-- │ +-- ↓ +-- @ module EuphApi.Threads ( -- * Events and replies @@ -13,21 +67,54 @@ module EuphApi.Threads ( import Control.Concurrent import Control.Exception -import Data.Aeson -import Data.Text -import qualified EuphApi.Types as E -import qualified Network.WebSockets as WS - --- Some useful type aliases -type PacketID = Text +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State +import Data.Aeson as A +import qualified Data.ByteString.Lazy as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified EuphApi.CloseableChan as E +import qualified EuphApi.Types as E +import qualified Network.WebSockets as WS {- - - Events and replies + - Some stuff -} +-- Some useful type aliases +type PacketID = T.Text +type Reply = Either Failure + -- | The ways in which getting a reply from the server can fail. -data Failure = FailDisconnect -- ^ Disconnected from the server while waiting for the reply. - | FailParse -- ^ Could not parse the server's reply correctly. +data Failure = FailDisconnect -- ^ Disconnected from the server while waiting for the reply. + | FailError T.Text -- ^ The server replied with an error. + | FailParse -- ^ Could not parse the server's reply correctly. + +class ToJSONObject a where + toJSONObject :: a -> Object + +(.?=) :: (ToJSON v, KeyValue kv) => T.Text -> Maybe v -> [kv] +k .?= (Just v) = [k .= v] +k .?= Nothing = [] + +packetOfType :: T.Text -> Value -> Object +packetOfType packetType packetData = + HM.fromList [("type", A.String packetType), ("data", packetData)] + +{- + - Commands + -} + +data SendCommand = SendCommand + { sendCommandContent :: T.Text + , sendCommandParent :: Maybe E.Snowflake + } deriving (Show) + +instance ToJSONObject SendCommand where + toJSONObject (SendCommand{..}) = + let obj = object $ ["content" .= sendCommandContent] ++ ("parent" .?= sendCommandParent) + in packetOfType "data" obj -- send-reply data SendReply = SendReply @@ -41,94 +128,95 @@ instance FromJSON SendReply where - API functions -} -send :: SendChan -> Text -> IO (Either Failure E.Message) +send :: SendChan -> T.Text -> IO (Reply E.Message) send = undefined -reply :: SendChan -> PacketID -> Text -> IO (Either Failure E.Message) +reply :: SendChan -> PacketID -> T.Text -> IO (Reply E.Message) reply = undefined +{- + - Channels + -} +type RecvChan = E.CloseableChan Recv +data Recv = RDisconnected + | RPacket BS.ByteString + | forall a . (FromJSON a) => RReply PacketID (MVar (Reply a)) +type SendChan = E.CloseableChan Send +data Send = SDisconnect + | forall p . (ToJSONObject p) => SNoReply p + | forall p r . (ToJSONObject p, FromJSON r) => SReply p (MVar (Reply r)) - - - - - - - - - - - - - - - - - - - - - - - - - +type EventChan e = E.CloseableChan (Event e) +data Event e = EDisconnected + | EStopped + | EEuphEventPlaceholder + | ECustomEvent e {- -data Packet = Packet - { packetID :: Maybe PacketID - , packetType :: Text - , packetContent :: Content - , packetThrottled :: Maybe Text - } --} + - Fetch thread + -} -type SendChan = Chan Send --- Contents of sendChan -data Send = SPacket Text --Value -- packet type, content - | SDisconnect - -type RecvChan = Chan Recv --- Contents of recvChan -data Recv = RConnectionClosed -- Ws connection closed --- | RPacket ByteString -- Packet received from the ws connection --- | forall c . (FromJSON c) => RReply PacketID (MVar (Response c)) -- Request for a reply with a certain ID - -{- -sendPacket :: Connection -> Packet -> IO () -sendPacket = undefined - -recvPacket :: Connection -> IO Packet -recvPacket = undefined - -sendThread :: SendChan -> RecvChan -> Connection -> IO () -sendThread s r c = do - return () - -type EventChan = Chan Event --- Contents of eventChan -data Event = EPlaceholder - -fetchMessage :: RecvChan -> Connection -> IO () -fetchMessage recv con = do - message <- receiveData con - writeChan recv (RPacket message) - fetchMessage recv con - -fetchThread :: RecvChan -> Connection -> IO () -fetchThread recv con = fetchMessage recv con `catch` handleException +fetchThread :: RecvChan -> WS.Connection -> IO () +fetchThread cRecv con = handle handleException $ forever $ do + message <- WS.receiveData con + void $ E.writeChan cRecv (RPacket message) -- will never be closed while thread running where - handleException (CloseRequest _ _) = writeChan recv RConnectionClosed - handleException ConnectionClosed = writeChan recv RConnectionClosed - handleException _ = fetchThread recv con + handleException (WS.CloseRequest _ _) = void $ E.writeChan cRecv RDisconnected + handleException WS.ConnectionClosed = void $ E.writeChan cRecv RDisconnected + handleException _ = fetchThread cRecv con -sendMessage :: SendChan -> RecvChan -> Connection -> IO () -sendMessage send recv con = do - message <- readChan send - return () - -sendThread :: SendChan -> RecvChan -> Connection -> IO () -sendThread = undefined +{- + - Send thread -} + +type SendState = StateT Integer IO + +-- Prepare a single packet for sending +preparePacket :: (ToJSONObject p) => p -> SendState (BS.ByteString, PacketID) +preparePacket packet = do + packetNr <- get + put $ packetNr + 1 + let packetID = T.pack $ show packetNr + obj = HM.insert "id" (A.String packetID) $ toJSONObject packet + bytestr = encode $ Object obj + return (bytestr, packetID) + + +sendThread :: SendChan -> RecvChan -> WS.Connection -> SendState () +sendThread cSend cRecv con = do + item <- liftIO $ E.readChan cSend + case item of + Nothing -> do + return () + + Just SDisconnect -> do + liftIO $ WS.sendClose con ("Bye." :: T.Text) + + Just (SNoReply value) -> do + (packet, _) <- preparePacket value + liftIO $ WS.sendTextData con packet + continue <- liftIO $ sendSafely packet + if continue + then sendThread cSend cRecv con + else return () + + Just (SReply value reply) -> do + (packet, packetID) <- preparePacket value + liftIO $ E.writeChan cRecv $ RReply packetID reply + continue <- liftIO $ sendSafely packet + if continue + then sendThread cSend cRecv con + else return () + where + sendSafely packet = (WS.sendTextData con packet >> return True) `catch` handleException + handleException (WS.CloseRequest _ _) = return False + handleException WS.ConnectionClosed = return False + handleException _ = return True + +{- + - RecvThread + -} + +-- TODO diff --git a/src/EuphApi/Types.hs b/src/EuphApi/Types.hs index 631f0da..bec5f72 100644 --- a/src/EuphApi/Types.hs +++ b/src/EuphApi/Types.hs @@ -1,11 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} --- | This module implements parts of the Euphoria API at +-- | This module implements a few types from the Euphoria API at -- . --- --- Currently, accounts are not implemented. --- This means that all account, room host and staff commands are not implemented. module EuphApi.Types ( Snowflake @@ -23,7 +20,8 @@ import Data.Time -- | Represents . -- --- A 'Snowflake' is a 13-character string, usually used as a unique identifier for some type of object. +-- A 'Snowflake' is a 13-character string, usually used as a unique identifier +-- for some type of object. -- It is the base-36 encoding of an unsigned, 64-bit integer. type Snowflake = T.Text @@ -45,8 +43,8 @@ instance FromJSON UserID where userType = findUserType tp userSnowflake = T.drop 1 sf in return $ if userType == Other - then UserID {userSnowflake=t, ..} - else UserID {..} + then UserID{userSnowflake=t, ..} + else UserID{..} where findUserType txt | txt == "account" = Account @@ -67,7 +65,8 @@ data UserType = Agent -- | Represents . -- -- A 'Message' is a node in a Room’s Log. --- It corresponds to a chat message, or a post, or any broadcasted event in a room that should appear in the log. +-- It corresponds to a chat message, or a post, or any broadcasted event in a room +-- that should appear in the log. -- -- The fields @previous_edit_id@ and @encryption_key_id@ are not implemented. data Message = Message @@ -108,7 +107,7 @@ instance FromJSON Message where msgEdited <- o .:? "edited" msgDeleted <- o .:? "deleted" msgTruncated <- o .:? "truncated" .!= False - return $ Message {..} + return $ Message{..} -- | Represents . -- @@ -136,4 +135,4 @@ instance FromJSON SessionView where sessSessionID <- o .: "session_id" isStaff <- o .:? "is_staff" .!= False isManager <- o .:? "is_manager" .!= False - return $ SessionView {..} + return $ SessionView{..}