From 4fda33bf55694424fbb280b5d6688cb326a8df9a Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 28 Jan 2018 15:15:43 +0000 Subject: [PATCH] Add events and some commands --- src/EuphApi/Threads.hs | 268 ++++++++++++++++++++++++++++++++++------- 1 file changed, 223 insertions(+), 45 deletions(-) diff --git a/src/EuphApi/Threads.hs b/src/EuphApi/Threads.hs index 2e79763..9f458b4 100644 --- a/src/EuphApi/Threads.hs +++ b/src/EuphApi/Threads.hs @@ -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 . +-- +-- 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