Clean up Types
This commit is contained in:
Joscha
parent
9636e1eb4d
commit
ce13ce11fc
3 changed files with 188 additions and 99 deletions
|
|
@ -24,12 +24,14 @@ dependencies:
|
|||
# basic stuff
|
||||
- time
|
||||
- text
|
||||
- transformers
|
||||
# websocket connection
|
||||
- websockets
|
||||
- wuss
|
||||
# parsing json
|
||||
- aeson
|
||||
- bytestring
|
||||
- unordered-containers
|
||||
# other
|
||||
- stm
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,61 @@
|
|||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | 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,22 +67,55 @@ module EuphApi.Threads (
|
|||
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Data.Aeson
|
||||
import Data.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
|
||||
|
||||
-- Some useful type aliases
|
||||
type PacketID = Text
|
||||
|
||||
{-
|
||||
- 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.
|
||||
| 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
|
||||
{ sendReplyMessage :: E.Message
|
||||
|
|
@ -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
|
||||
{-
|
||||
- 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 ()
|
||||
|
||||
sendThread :: SendChan -> RecvChan -> Connection -> IO ()
|
||||
sendThread = undefined
|
||||
-}
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-- <http://api.euphoria.io/#overview>.
|
||||
--
|
||||
-- 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 <http://api.euphoria.io/#snowflake>.
|
||||
--
|
||||
-- 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 <http://api.euphoria.io/#message>.
|
||||
--
|
||||
-- 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 <http://api.euphoria.io/#sessionview>.
|
||||
--
|
||||
|
|
@ -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{..}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue