Add events and some commands
This commit is contained in:
Joscha
parent
6237a91d9b
commit
4fda33bf55
1 changed files with 223 additions and 45 deletions
|
|
@ -60,11 +60,13 @@
|
|||
module EuphApi.Threads (
|
||||
-- * Events and replies
|
||||
Failure(..)
|
||||
-- * Functions for using the api
|
||||
, send
|
||||
, reply
|
||||
, Event(..)
|
||||
, EuphEvent(..)
|
||||
-- * API functions
|
||||
, pingReply
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
|
|
@ -74,65 +76,241 @@ 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 Data.Time
|
||||
import Data.Time.Clock.POSIX
|
||||
import qualified EuphApi.CloseableChan as E
|
||||
import qualified EuphApi.Types as E
|
||||
import qualified Network.WebSockets as WS
|
||||
|
||||
{-
|
||||
- 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.
|
||||
data Failure = FailClosed -- ^ Could not send message because connection was closed.
|
||||
| FailDisconnect -- ^ Disconnected from 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
|
||||
{-
|
||||
- Commands and replies
|
||||
-}
|
||||
|
||||
(.?=) :: (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)]
|
||||
-- ping reply/command/whatever
|
||||
|
||||
{-
|
||||
- Commands
|
||||
-}
|
||||
newtype PingReplyCommand = PingReplyCommand
|
||||
{ pingReplyCommandTime :: UTCTime
|
||||
} deriving (Show)
|
||||
|
||||
instance ToJSON PingReplyCommand where
|
||||
toJSON PingReplyCommand{..} =
|
||||
object ["time" .= utcTimeToPOSIXSeconds pingReplyCommandTime]
|
||||
|
||||
-- nick command and reply
|
||||
|
||||
newtype NickCommand = NickCommand
|
||||
{ nickCommandName :: T.Text
|
||||
} deriving (Show)
|
||||
|
||||
instance ToJSON NickCommand where
|
||||
toJSON NickCommand{..} =
|
||||
object ["name" .= nickCommandName]
|
||||
|
||||
data NickReply = NickReply
|
||||
{ nickReplySessionID :: E.SessionID
|
||||
, nickReplyUserID :: E.UserID
|
||||
, nickReplyFrom :: T.Text
|
||||
, nickReplyTo :: T.Text
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON NickReply where
|
||||
parseJSON = withObject "NickReply" $ \o -> do
|
||||
nickReplySessionID <- o .: "session_id"
|
||||
nickReplyUserID <- o .: "id"
|
||||
nickReplyFrom <- o .: "from"
|
||||
nickReplyTo <- o .: "to"
|
||||
return NickReply{..}
|
||||
|
||||
-- send command and reply
|
||||
|
||||
data SendCommand = SendCommand
|
||||
{ sendCommandContent :: T.Text
|
||||
, sendCommandParent :: Maybe E.Snowflake
|
||||
, sendCommandParent :: Maybe PacketID
|
||||
} deriving (Show)
|
||||
|
||||
instance ToJSONObject SendCommand where
|
||||
toJSONObject (SendCommand{..}) =
|
||||
let obj = object $ ["content" .= sendCommandContent] ++ ("parent" .?= sendCommandParent)
|
||||
in packetOfType "data" obj
|
||||
instance ToJSON SendCommand where
|
||||
toJSON SendCommand{..} =
|
||||
object $ ("content" .= sendCommandContent) : ("parent" .?= sendCommandParent)
|
||||
|
||||
-- send-reply
|
||||
data SendReply = SendReply
|
||||
newtype SendReply = SendReply
|
||||
{ sendReplyMessage :: E.Message
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON SendReply where
|
||||
parseJSON v = SendReply <$> parseJSON v
|
||||
|
||||
{-
|
||||
- Events
|
||||
-}
|
||||
|
||||
-- | Represents <http://api.euphoria.io/#asynchronous-events>.
|
||||
--
|
||||
-- These events may be sent from the server to the client at any time.
|
||||
data EuphEvent = BounceEvent (Maybe T.Text) (Maybe [T.Text])
|
||||
-- ^ A 'BounceEvent' indicates that access to a room is denied.
|
||||
--
|
||||
-- @'BounceEvent' (Maybe reason) (Maybe [authOption])@
|
||||
| DisconnectEvent T.Text
|
||||
-- ^ A 'DisconnectEvent' indicates that the session is being closed.
|
||||
-- The client will subsequently be disconnected.
|
||||
--
|
||||
-- If the disconnect reason is "authentication changed", the client should immediately reconnect.
|
||||
--
|
||||
-- @'DisconnectEvent' reason@
|
||||
| HelloEvent E.SessionView Bool T.Text
|
||||
-- ^ A 'HelloEvent' is sent by the server to the client when a session is started.
|
||||
-- It includes information about the client's authentication and associated identity.
|
||||
--
|
||||
-- @'HelloEvent' session roomIsPrivate version@
|
||||
| JoinEvent E.SessionView
|
||||
-- ^ A 'JoinEvent' indicates a session just joined the room.
|
||||
--
|
||||
-- @'JoinEvent' session@
|
||||
| NetworkEvent T.Text T.Text
|
||||
-- ^ A 'NetworkEvent' indicates some server-side event that impacts the presence of sessions in a room.
|
||||
--
|
||||
-- If the network event type is "partition", then this should be treated as a 'PartEvent' for all sessions connected to the same server id/era combo.
|
||||
--
|
||||
-- @'NetworkEvent' server_id server_era@
|
||||
| NickEvent E.Nick E.Nick
|
||||
-- ^ A 'NickEvent' announces a nick change by another session in the room.
|
||||
--
|
||||
-- @'NickEvent' from to@
|
||||
| EditMessageEvent E.Message
|
||||
-- ^ An 'EditMessageEvent' indicates that a message in the room has been modified or deleted.
|
||||
-- If the client offers a user interface and the indicated message is currently displayed, it should update its display accordingly.
|
||||
--
|
||||
-- The event packet includes a snapshot of the message post-edit.
|
||||
--
|
||||
-- @'EditMessageEvent' editedMessage@
|
||||
| PartEvent E.SessionView
|
||||
-- ^ A 'PartEvent' indicates a session just disconnected from the room.
|
||||
--
|
||||
-- @'PartEvent' session@
|
||||
| PingEvent UTCTime UTCTime
|
||||
-- ^ A 'PingEvent' represents a server-to-client ping.
|
||||
-- The client should send back a 'pingReply' with the same value for the time field as soon as possible (or risk disconnection).
|
||||
--
|
||||
-- @'PingEvent' time next@
|
||||
| SendEvent E.Message
|
||||
-- ^ A 'SendEvent' indicates a message received by the room from another session.
|
||||
--
|
||||
-- @'SendEvent' message@
|
||||
| SnapshotEvent T.Text [E.SessionView] [E.Message] (Maybe E.Nick)
|
||||
-- ^ A 'SnapshotEvent' indicates that a session has successfully joined a room.
|
||||
-- It also offers a snapshot of the room’s state and recent history.
|
||||
--
|
||||
-- @'SnapshotEvent' version listing log (Maybe nick)@
|
||||
|
||||
-- LoginEvent -- not implemented
|
||||
-- LogoutEvent -- not implemented
|
||||
-- PMInitiateEvent -- not implemented
|
||||
|
||||
instance FromJSON EuphEvent where
|
||||
parseJSON = withObject "Event" $ \o -> do
|
||||
tp <- o .: "type"
|
||||
dt <- o .: "data"
|
||||
empty
|
||||
<|> (tp `is` "bounce-event" >> pBounceEvent dt)
|
||||
<|> (tp `is` "disconnect-event" >> pDisconnectEvent dt)
|
||||
<|> (tp `is` "hello-event" >> pHelloEvent dt)
|
||||
<|> (tp `is` "join-event" >> pJoinEvent dt)
|
||||
<|> (tp `is` "network-event" >> pNetworkEvent dt)
|
||||
<|> (tp `is` "nick-event" >> pNickEvent dt)
|
||||
<|> (tp `is` "edit-message-event" >> pEditMessageEvent dt)
|
||||
<|> (tp `is` "part-event" >> pPartEvent dt)
|
||||
<|> (tp `is` "ping-event" >> pPingEvent dt)
|
||||
<|> (tp `is` "send-event" >> pSendEvent dt)
|
||||
<|> (tp `is` "snapshot-event" >> pSnapshotEvent dt)
|
||||
where
|
||||
a `is` b = guard ((a :: T.Text) == b)
|
||||
pBounceEvent = withObject "BounceEvent" $ \o ->
|
||||
BounceEvent <$> o .:? "reason" <*> o .:? "auth_options"
|
||||
pDisconnectEvent = withObject "DisconnectEvent" $ \o ->
|
||||
DisconnectEvent <$> o .: "reason"
|
||||
pHelloEvent = withObject "HelloEvent" $ \o ->
|
||||
HelloEvent <$> o .: "session" <*> o .: "room_is_private" <*> o .: "version"
|
||||
pJoinEvent v = JoinEvent <$> parseJSON v
|
||||
pNetworkEvent = withObject "NetworkEvent" $ \o ->
|
||||
NetworkEvent <$> o .: "server_id" <*> o .: "server_era"
|
||||
pNickEvent = withObject "NickEvent" $ \o ->
|
||||
NickEvent <$> o .: "from" <*> o .: "to"
|
||||
pEditMessageEvent v = EditMessageEvent <$> parseJSON v
|
||||
pPartEvent v = PartEvent <$> parseJSON v
|
||||
pPingEvent = withObject "PingEvent" $ \o ->
|
||||
PingEvent <$> o .: "time" <*> o .: "next"
|
||||
pSendEvent v = SendEvent <$> parseJSON v
|
||||
pSnapshotEvent = withObject "SnapshotEvent" $ \o ->
|
||||
SnapshotEvent <$> o .: "version" <*> o .: "listing" <*> o .: "log" <*> o .:? "nick"
|
||||
|
||||
{-
|
||||
- API functions
|
||||
-}
|
||||
|
||||
pingReply :: SendChan -> UTCTime -> IO (Reply ())
|
||||
pingReply = undefined
|
||||
|
||||
{-
|
||||
pingReply chan time = do
|
||||
let obj = object $ ["time" .= utcTimeToPOSIXSeconds time]
|
||||
packet = packetOfType "ping-reply" obj
|
||||
sent <- liftIO $ E.writeChan chan $ SNoReply packet
|
||||
case sent of
|
||||
Nothing -> return $ Left FailClosed
|
||||
Just _ -> return $ Right ()
|
||||
|
||||
nick :: SendChan -> T.Text -> IO (Reply (T.Text, T.Text))
|
||||
nick chan newNick = do
|
||||
let obj = object $ ["name" .= newNick]
|
||||
packet = packetOfType "nick" obj
|
||||
var <- liftIO newEmptyMVar
|
||||
sent <- liftIO $ E.writeChan chan $ SReply packet var
|
||||
case sent of
|
||||
Nothing -> return $ Left FailClosed
|
||||
Just _ -> do
|
||||
reply <- readMVar var
|
||||
case reply of
|
||||
Left f -> return $ Left f
|
||||
Right NickReply{..} -> return $ Right (nickReplyFrom, nickReplyTo)
|
||||
|
||||
send :: SendChan -> T.Text -> IO (Reply E.Message)
|
||||
send = undefined
|
||||
send chan content = do
|
||||
let obj = object $ ["content" .= content]
|
||||
packet = packetOfType "send" obj
|
||||
var <- liftIO newEmptyMVar
|
||||
sent <- liftIO $ E.writeChan chan $ SReply packet var
|
||||
case sent of
|
||||
Nothing -> return $ Left FailClosed
|
||||
Just _ -> do
|
||||
reply <- readMVar var
|
||||
return $ sendReplyMessage <$> reply
|
||||
|
||||
reply :: SendChan -> PacketID -> T.Text -> IO (Reply E.Message)
|
||||
reply = undefined
|
||||
reply chan parent content = do
|
||||
let obj = object $ ["content" .= content, "parent" .= parent]
|
||||
packet = packetOfType "send" obj
|
||||
var <- liftIO newEmptyMVar
|
||||
sent <- liftIO $ E.writeChan chan $ SReply packet var
|
||||
case sent of
|
||||
Nothing -> return $ Left FailClosed
|
||||
Just _ -> do
|
||||
reply <- readMVar var
|
||||
return $ sendReplyMessage <$> reply
|
||||
-}
|
||||
|
||||
{-
|
||||
- Channels
|
||||
|
|
@ -145,13 +323,13 @@ data Recv = RDisconnected
|
|||
|
||||
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))
|
||||
| forall p . (ToJSON p) => SNoReply T.Text p -- packet type and contents
|
||||
| forall p r . (ToJSON p, FromJSON r) => SReply T.Text p (MVar (Reply r))
|
||||
|
||||
type EventChan e = E.CloseableChan (Event e)
|
||||
data Event e = EDisconnected
|
||||
| EStopped
|
||||
| EEuphEventPlaceholder
|
||||
| EEuphEvent EuphEvent
|
||||
| ECustomEvent e
|
||||
|
||||
{-
|
||||
|
|
@ -174,41 +352,41 @@ fetchThread cRecv con = handle handleException $ forever $ do
|
|||
type SendState = StateT Integer IO
|
||||
|
||||
-- Prepare a single packet for sending
|
||||
preparePacket :: (ToJSONObject p) => p -> SendState (BS.ByteString, PacketID)
|
||||
preparePacket packet = do
|
||||
preparePacket :: (ToJSON p) => T.Text -> p -> SendState (BS.ByteString, PacketID)
|
||||
preparePacket packetType packetData = 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
|
||||
bytestr = encode . Object . HM.fromList $
|
||||
[ ("id", A.String packetID)
|
||||
, ("type", A.String packetType)
|
||||
, ("data", toJSON packetData)
|
||||
]
|
||||
return (bytestr, packetID)
|
||||
|
||||
|
||||
sendThread :: SendChan -> RecvChan -> WS.Connection -> SendState ()
|
||||
sendThread cSend cRecv con = do
|
||||
item <- liftIO $ E.readChan cSend
|
||||
case item of
|
||||
Nothing -> do
|
||||
Nothing ->
|
||||
return ()
|
||||
|
||||
Just SDisconnect -> do
|
||||
Just SDisconnect ->
|
||||
liftIO $ WS.sendClose con ("Bye." :: T.Text)
|
||||
|
||||
Just (SNoReply value) -> do
|
||||
(packet, _) <- preparePacket value
|
||||
Just (SNoReply packetType packetData) -> do
|
||||
(packet, _) <- preparePacket packetType packetData
|
||||
liftIO $ WS.sendTextData con packet
|
||||
continue <- liftIO $ sendSafely packet
|
||||
if continue
|
||||
then sendThread cSend cRecv con
|
||||
else return ()
|
||||
when continue $
|
||||
sendThread cSend cRecv con
|
||||
|
||||
Just (SReply value reply) -> do
|
||||
(packet, packetID) <- preparePacket value
|
||||
Just (SReply packetType packetData reply) -> do
|
||||
(packet, packetID) <- preparePacket packetType packetData
|
||||
liftIO $ E.writeChan cRecv $ RReply packetID reply
|
||||
continue <- liftIO $ sendSafely packet
|
||||
if continue
|
||||
then sendThread cSend cRecv con
|
||||
else return ()
|
||||
when continue $
|
||||
sendThread cSend cRecv con
|
||||
where
|
||||
sendSafely packet = (WS.sendTextData con packet >> return True) `catch` handleException
|
||||
handleException (WS.CloseRequest _ _) = return False
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue