Garmelon/euph-api
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Structure api functions

Browse source
This commit is contained in:
Joscha 2018-01-28 19:13:18 +00:00
parent 5b251d23b8
commit dfe3445ff3
1 changed files with 74 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

84
src/EuphApi/Threads.hs
View file

@ -64,6 +64,7 @@ module EuphApi.Threads (
, EuphEvent(..)
-- * API functions
, pingReply
, nick
) where
import Control.Applicative
@ -71,6 +72,7 @@ import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.State
import Data.Aeson as A
import qualified Data.ByteString.Lazy as BS
@ -92,6 +94,50 @@ data Failure = FailClosed -- ^ Could not send message because connection w
| FailError T.Text -- ^ The server replied with an error.
| FailParse -- ^ Could not parse the server's reply correctly.
instance Show Failure where
show FailClosed = "Connection already closed"
show FailDisconnect = "Disconnected from server"
show (FailError t) = "Server error: " ++ T.unpack t
show FailParse = "Parsing failed"
instance Exception Failure
sendPacket :: (ToJSON p, FromJSON r) => SendChan -> T.Text -> p -> IO r
sendPacket chan packetType packetData = do
var <- newEmptyMVar
let packet = SReply packetType packetData var
done <- E.writeChan chan packet
case done of
Nothing -> throw FailClosed
Just () -> do
result <- readMVar var
case result of
Left f -> throw f
Right r -> return r
sendPacketNoReply :: (ToJSON p) => SendChan -> T.Text -> p -> IO ()
sendPacketNoReply chan packetType packetData = do
let packet = SNoReply packetType packetData
done <- E.writeChan chan packet
case done of
Nothing -> throw FailClosed
Just () -> return ()
{-
- API functions
-}
pingReply :: SendChan -> UTCTime -> IO ()
pingReply chan time = do
let cmd = PingReplyCommand time
sendPacketNoReply chan "ping-reply" cmd
nick :: SendChan -> T.Text -> IO (E.Nick, E.Nick)
nick chan name = do
let cmd = NickCommand name
NickReply{..} <- sendPacket chan "nick" cmd
return (nickReplyFrom, nickReplyTo)
{-
- Commands and replies
-}
@ -168,12 +214,15 @@ data EuphEvent = BounceEvent (Maybe T.Text) (Maybe [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.
-- 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.
-- ^ 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
@ -181,9 +230,12 @@ data EuphEvent = BounceEvent (Maybe T.Text) (Maybe [T.Text])
--
-- @'JoinEvent' session@
| NetworkEvent T.Text T.Text
-- ^ A 'NetworkEvent' indicates some server-side event that impacts the presence of sessions in a room.
-- ^ 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.
-- 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
@ -191,8 +243,10 @@ data EuphEvent = BounceEvent (Maybe T.Text) (Maybe [T.Text])
--
-- @'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.
-- ^ 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.
--
@ -203,15 +257,18 @@ data EuphEvent = BounceEvent (Maybe T.Text) (Maybe [T.Text])
-- @'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).
-- 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.
-- ^ 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.
-- ^ 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)@
@ -257,13 +314,6 @@ instance FromJSON EuphEvent where
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]