733 lines
25 KiB
Haskell
733 lines
25 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
||
{-# LANGUAGE LambdaCase #-}
|
||
{-# 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.
|
||
--
|
||
-- Objects of type 'Connection' represent a connection to a server.
|
||
-- @Connection@s can't be reused, so to reconnect to a server, a new @Connection@ object
|
||
-- must be used.
|
||
--
|
||
-- To connect to a server, a new connection must be created using the
|
||
-- 'startEuphConnection' command.
|
||
--
|
||
-- == Example
|
||
--
|
||
-- > import qualified EuphApi.Connection as E
|
||
-- >
|
||
-- > main = do
|
||
-- > putStrLn "> Connecting to euphoria.io, &test"
|
||
-- > con <- E.startEuphConnection "euphoria.io" "test"
|
||
-- > printEvents con
|
||
-- > where
|
||
-- > printEvents con = do
|
||
-- > event <- E.getEvent con
|
||
-- > case event of
|
||
-- > ConnectionFailed -> putStrLn "> Could not connect. Are you sure that room exists?"
|
||
-- > Disconnected -> putStrLn "> Connection closed. Bye!"
|
||
-- > EuphEvent e -> print e
|
||
|
||
module EuphApi.Connection (
|
||
-- * Connecting to euphoria
|
||
Connection
|
||
, startEuphConnection
|
||
, getEvent
|
||
-- * API functions
|
||
, disconnect
|
||
, pingReply
|
||
-- ** Session commands
|
||
, auth
|
||
, ping
|
||
-- ** Chat room commands
|
||
, getMessage
|
||
, messageLog
|
||
, nick
|
||
-- pmInitiate
|
||
, send
|
||
, who
|
||
-- * Events and Exceptions
|
||
, EuphException(..)
|
||
, EventType(..)
|
||
, Event(..)
|
||
) where
|
||
|
||
import Control.Applicative
|
||
import Control.Exception
|
||
import Control.Monad
|
||
import Control.Monad.IO.Class
|
||
|
||
import Control.Concurrent
|
||
import Control.Concurrent.Async
|
||
import Control.Concurrent.STM
|
||
import Control.Monad.Trans.State
|
||
import Data.Aeson
|
||
import Data.Aeson.Types
|
||
import qualified Data.ByteString.Lazy as BS
|
||
import qualified Data.HashMap.Strict as HM
|
||
import qualified Data.Map as M
|
||
import qualified Data.Text as T
|
||
import Data.Time
|
||
import Data.Time.Clock.POSIX
|
||
import qualified Network.WebSockets as WS
|
||
import qualified Wuss as WSS
|
||
|
||
import qualified EuphApi.Types as E
|
||
|
||
type PacketID = T.Text
|
||
type Reply = Either EuphException
|
||
data ReplyMVar = forall r . (FromJSON r) => ReplyMVar (MVar (Reply r))
|
||
|
||
type SendQueue = TBQueue Send
|
||
type EventQueue = TBQueue EventType
|
||
type LockedFlag = TVar Bool
|
||
|
||
-- | A connection to a room on euphoria.
|
||
data Connection = Connection LockedFlag SendQueue EventQueue
|
||
|
||
-- | Read one event from the 'Connection'.
|
||
--
|
||
-- If the @Connection@ could not connect, this returns 'ConnectionFailed' once.
|
||
-- If the @Connection@ stops, this returns 'Disconnected' once.
|
||
--
|
||
-- After either a @ConnectionFailed@ or a @Disconnected@, any further calls
|
||
-- of @getEvent@ on the same @Connection@ will block indefinitely.
|
||
getEvent :: Connection -> IO EventType
|
||
getEvent (Connection _ _ qEvent) = atomically $ readTBQueue qEvent
|
||
|
||
-- | Creates a new 'Connection' that will attempt to connect to a given room:
|
||
--
|
||
-- > con <- startEuphConnection server room
|
||
startEuphConnection :: String -> String -> IO Connection
|
||
startEuphConnection host room = do
|
||
sendQueue <- atomically $ newTBQueue 10
|
||
eventQueue <- atomically $ newTBQueue 10
|
||
locked <- atomically $ newTVar False
|
||
let euphCon = Connection locked sendQueue eventQueue
|
||
void
|
||
$ forkIO
|
||
$ handle (handleException eventQueue)
|
||
$ WSS.runSecureClient host 443 ("/room/" ++ room ++ "/ws")
|
||
$ recvClient euphCon
|
||
return euphCon
|
||
where
|
||
handleException :: EventQueue -> WS.HandshakeException -> IO ()
|
||
handleException qEvent _ = atomically $ writeTBQueue qEvent ConnectionFailed
|
||
|
||
{-
|
||
- Send thread
|
||
-}
|
||
|
||
-- Prepare a single packet for sending.
|
||
-- Doesn't actually do any IO. The IO monad part is left in for ease of use.
|
||
preparePacket :: (ToJSON p) => T.Text -> p -> StateT Integer IO (BS.ByteString, PacketID)
|
||
preparePacket packetType packetData = do
|
||
packetNr <- get
|
||
modify (+1)
|
||
let packetID = T.pack $ show packetNr
|
||
bytestr = encode . Object . HM.fromList $
|
||
[ ("id", String packetID)
|
||
, ("type", String packetType)
|
||
, ("data", toJSON packetData)
|
||
]
|
||
return (bytestr, packetID)
|
||
|
||
readWhileOpen :: Connection -> STM (Maybe Send)
|
||
readWhileOpen (Connection locked qSend _) = do
|
||
isLocked <- readTVar locked
|
||
if isLocked
|
||
then return Nothing
|
||
else Just <$> readTBQueue qSend
|
||
|
||
sendThread :: RecvInfo -> StateT Integer IO ()
|
||
sendThread info@RecvInfo{..} = do
|
||
item <- liftIO $ atomically $ readWhileOpen recvEuphCon
|
||
case item of
|
||
Nothing ->
|
||
return ()
|
||
|
||
Just SDisconnect ->
|
||
liftIO $ WS.sendClose recvCon ("Bye. -EuphApi" :: T.Text)
|
||
|
||
Just (SNoReply packetType packetData) -> do
|
||
(packet, _) <- preparePacket packetType packetData
|
||
continue <- liftIO $ sendSafely packet
|
||
when continue $
|
||
sendThread info
|
||
|
||
Just (SReply packetType packetData reply) -> do
|
||
(packet, packetID) <- preparePacket packetType packetData
|
||
liftIO $ atomically $ modifyTVar recvWaiting (M.insert packetID reply)
|
||
continue <- liftIO $ sendSafely packet
|
||
when continue $
|
||
sendThread info
|
||
where
|
||
sendSafely packet = (WS.sendTextData recvCon packet >> return True) `catch` handleException
|
||
handleException (WS.CloseRequest _ _) = return False
|
||
handleException WS.ConnectionClosed = return False
|
||
handleException _ = return True
|
||
-- TODO: Think about whether this is safe (memory leak issues etc.)
|
||
|
||
{-
|
||
- Receive thread
|
||
-}
|
||
|
||
data PacketInfo = PacketInfo
|
||
{ infoPacketID :: Maybe PacketID
|
||
, infoData :: Either T.Text Value
|
||
} deriving (Show)
|
||
|
||
instance FromJSON PacketInfo where
|
||
parseJSON = withObject "packet" $ \o -> do
|
||
infoPacketID <- o .:? "id"
|
||
packetData <- o .:? "data"
|
||
infoData <- case packetData of
|
||
Nothing -> Left <$> o .: "error"
|
||
Just d -> return $ Right d
|
||
return PacketInfo{..}
|
||
|
||
data RecvInfo = RecvInfo
|
||
{ recvEuphCon :: Connection
|
||
, recvCon :: WS.Connection
|
||
, recvWaiting :: TVar Awaiting
|
||
}
|
||
|
||
-- TODO: Swap for HashMap?
|
||
type Awaiting = M.Map T.Text ReplyMVar
|
||
|
||
whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
|
||
whenJust m f = maybe (return ()) f m
|
||
|
||
processEvent :: BS.ByteString -> RecvInfo -> IO ()
|
||
processEvent bs RecvInfo{..} = do
|
||
let (Connection _ _ qEvent) = recvEuphCon
|
||
case decode bs of
|
||
Nothing -> return ()
|
||
Just event -> atomically $ writeTBQueue qEvent (EuphEvent event)
|
||
|
||
processReply :: BS.ByteString -> RecvInfo -> IO ()
|
||
processReply bs RecvInfo{..} = do
|
||
-- Figure out whether this packet is actually a reply of some sort.
|
||
let maybeInfo = do
|
||
PacketInfo{..} <- decode bs
|
||
replyID <- infoPacketID
|
||
return (replyID, infoData)
|
||
whenJust maybeInfo $ \(replyID, infoData) -> do
|
||
-- Figure out whether we're waiting for that ID and find the correct MVar
|
||
-- and remove it from the TVar if we do find it.
|
||
maybeReplyMVar <- atomically $ do
|
||
waiting <- readTVar recvWaiting
|
||
case M.lookup replyID waiting of
|
||
Nothing -> return Nothing
|
||
Just var -> do
|
||
modifyTVar recvWaiting (M.delete replyID)
|
||
return (Just var)
|
||
whenJust maybeReplyMVar $ \(ReplyMVar var) ->
|
||
-- We now know that the packet is a reply, and we know the MVar to send
|
||
-- it to. Now we only need to send the correct reply through the MVar.
|
||
case infoData of
|
||
Left e -> putMVar var (Left $ EuphServerError e)
|
||
Right d ->
|
||
case parseEither parseJSON d of
|
||
Left e -> putMVar var (Left $ EuphParse e bs)
|
||
Right r -> putMVar var (Right r)
|
||
|
||
processRecv :: RecvInfo -> IO ()
|
||
processRecv info@RecvInfo{..} = handle handleException $ forever $ do
|
||
message <- WS.receiveData recvCon -- retrieve packet from ws connection
|
||
processEvent message info
|
||
processReply message info
|
||
where
|
||
handleException (WS.CloseRequest _ _) = return ()
|
||
handleException WS.ConnectionClosed = return ()
|
||
handleException _ = processRecv info -- continue running
|
||
|
||
cleanupWaiting :: Awaiting -> IO ()
|
||
cleanupWaiting replies =
|
||
forM_ replies $ \(ReplyMVar var) -> putMVar var (Left EuphDisconnected)
|
||
|
||
emptyTBQueue :: TBQueue a -> STM [a]
|
||
emptyTBQueue q = do
|
||
isEmpty <- isEmptyTBQueue q
|
||
if isEmpty
|
||
then return []
|
||
else do
|
||
item <- readTBQueue q
|
||
rest <- emptyTBQueue q
|
||
return $ item : rest
|
||
|
||
cleanupSend :: SendQueue -> IO ()
|
||
cleanupSend qSend = do
|
||
sends <- atomically $ emptyTBQueue qSend
|
||
forM_ sends $ \case
|
||
SReply _ _ (ReplyMVar var) -> putMVar var (Left EuphDisconnected)
|
||
_ -> return ()
|
||
|
||
recvClient :: Connection -> WS.ClientApp ()
|
||
recvClient euphCon@(Connection locked qSend qEvent) con = do
|
||
waiting <- atomically $ newTVar M.empty
|
||
let info = RecvInfo{recvEuphCon=euphCon, recvCon=con, recvWaiting=waiting}
|
||
tSend <- async $ evalStateT (sendThread info) 0
|
||
processRecv info
|
||
-- Stop and clean up stuff
|
||
atomically $ writeTVar locked True
|
||
wait tSend
|
||
cleanupSend qSend
|
||
atomically (readTVar waiting) >>= cleanupWaiting
|
||
atomically $ writeTBQueue qEvent Disconnected
|
||
|
||
{-
|
||
- API functions
|
||
-}
|
||
|
||
writeSend :: Connection -> Send -> STM ()
|
||
writeSend (Connection locked qSend _) s = do
|
||
isLocked <- readTVar locked
|
||
if isLocked
|
||
then throwSTM EuphClosed
|
||
else writeTBQueue qSend s
|
||
|
||
sendPacket :: (ToJSON p, FromJSON r) => Connection -> T.Text -> p -> IO r
|
||
sendPacket euphCon packetType packetData = do
|
||
var <- newEmptyMVar
|
||
let packet = SReply packetType packetData (ReplyMVar var)
|
||
atomically $ writeSend euphCon packet
|
||
result <- readMVar var
|
||
case result of
|
||
Left f -> throw f
|
||
Right r -> return r
|
||
|
||
sendPacketNoReply :: (ToJSON p) => Connection -> T.Text -> p -> IO ()
|
||
sendPacketNoReply euphCon packetType packetData = do
|
||
let packet = SNoReply packetType packetData
|
||
atomically $ writeSend euphCon packet
|
||
|
||
-- | Close the 'Connection'. This will result in a 'Disconnected' event.
|
||
disconnect :: Connection -> IO ()
|
||
disconnect euphCon = atomically $ writeSend euphCon SDisconnect
|
||
|
||
-- | Reply to the server's 'PingEvent',
|
||
-- as described in <http://api.euphoria.io/#ping-event>.
|
||
pingReply :: Connection -> UTCTime -> IO ()
|
||
pingReply euphCon pingReplyCommandTime =
|
||
sendPacketNoReply euphCon "ping-reply" PingReplyCommand{..}
|
||
|
||
-- | Implements <http://api.euphoria.io/#auth>.
|
||
--
|
||
-- The 'auth' command attempts to join a private room.
|
||
-- It should be sent in response to a 'BounceEvent' at the beginning of a session.
|
||
--
|
||
-- The reply reports whether the @auth@ command succeeded.
|
||
-- 'Nothing' implies success whereas @'Just' error@ reports an authentication error.
|
||
--
|
||
-- > success <- auth con passcode
|
||
auth :: Connection -> T.Text -> IO (Maybe T.Text)
|
||
auth euphCon authCommandPasscode = do
|
||
AuthReply{..} <- sendPacket euphCon "auth" AuthCommand{..}
|
||
return authReplySuccess
|
||
|
||
-- | Implements <http://api.euphoria.io/#ping>.
|
||
--
|
||
-- The 'ping' command initiates a client-to-server ping.
|
||
-- The server will send back a reply with the same timestamp as soon as possible.
|
||
--
|
||
-- This uses the current time as value for the @time@ field.
|
||
-- Might be useful to check whether a connection still works.
|
||
-- Could also be used for measuring the server delay.
|
||
-- As all other api functions, this will also throw an exception if the connection closed.
|
||
--
|
||
-- > ping con
|
||
ping :: Connection -> IO ()
|
||
ping euphCon = do
|
||
pingCommandTime <- getCurrentTime
|
||
PingReply{..} <- sendPacket euphCon "ping" PingCommand{..}
|
||
return ()
|
||
|
||
-- | Implements <http://api.euphoria.io/#get-message>.
|
||
--
|
||
-- The 'getMessage' command retrieves the full content of a single message in the room.
|
||
--
|
||
-- > message <- getMessage con id
|
||
getMessage :: Connection -> E.Snowflake -> IO E.Message
|
||
getMessage euphCon getMessageCommandID = do
|
||
GetMessageReply{..} <- sendPacket euphCon "get-message" GetMessageCommand{..}
|
||
return getMessageReplyMessage
|
||
|
||
-- | Implements <http://api.euphoria.io/#log>.
|
||
--
|
||
-- The 'messageLog' command requests messages from the room’s message log.
|
||
-- This can be used to supplement the log provided by 'SnapshotEvent'
|
||
-- (for example, when scrolling back further in history).
|
||
--
|
||
-- The command returns a list of 'E.Message's from the room’s message log.
|
||
--
|
||
-- > (log, Maybe before) <- messageLog con amount (Maybe before)
|
||
messageLog :: Connection
|
||
-> Integer
|
||
-> Maybe E.Snowflake
|
||
-> IO ([E.Message], Maybe E.Snowflake)
|
||
messageLog euphCon logCommandN logCommandBefore = do
|
||
LogReply{..} <- sendPacket euphCon "log" LogCommand{..}
|
||
return (logReplyLog, logReplyBefore)
|
||
|
||
-- | Implements <http://api.euphoria.io/#nick>.
|
||
--
|
||
-- The 'nick' command sets the name you present to the room.
|
||
-- This name applies to all messages sent during this session,
|
||
-- until the @nick@ command is called again.
|
||
--
|
||
-- The reply confirms the @nick@ command.
|
||
-- It returns the session’s former and new names
|
||
-- (the server may modify the requested nick).
|
||
--
|
||
-- > (from, to) <- nick con name
|
||
nick :: Connection -> T.Text -> IO (E.Nick, E.Nick)
|
||
nick euphCon nickCommandName = do
|
||
NickReply{..} <- sendPacket euphCon "nick" NickCommand{..}
|
||
return (nickReplyFrom, nickReplyTo)
|
||
|
||
-- | Implements <http://api.euphoria.io/#send>.
|
||
--
|
||
-- The 'send' command sends a message to a room.
|
||
-- The session must be successfully joined with the room.
|
||
-- This message will be broadcast to all sessions joined with the room.
|
||
--
|
||
-- If the room is private, then the message content will be encrypted
|
||
-- before it is stored and broadcast to the rest of the room.
|
||
--
|
||
-- The caller of this command will not receive the corresponding 'SendEvent',
|
||
-- but will receive the same information in the reply.
|
||
--
|
||
-- The reply returns the 'E.Message' that was sent.
|
||
-- This includes the message id ('E.Snowflake'), which was populated by the server.
|
||
--
|
||
-- > message <- send (Maybe parentID) content
|
||
send :: Connection -> Maybe E.Snowflake -> T.Text -> IO E.Message
|
||
send euphCon sendCommandParent sendCommandContent = do
|
||
SendReply{..} <- sendPacket euphCon "send" SendCommand{..}
|
||
return sendReplyMessage
|
||
|
||
-- | Implements <http://api.euphoria.io/#who>.
|
||
--
|
||
-- The who command returns a list of sessions currently joined in the room.
|
||
--
|
||
-- > sessions <- who
|
||
who :: Connection -> IO [E.SessionView]
|
||
who euphCon = do
|
||
WhoReply{..} <- sendPacket euphCon "who" WhoCommand
|
||
return whoReplyListing
|
||
|
||
|
||
|
||
{-
|
||
- Some types
|
||
-}
|
||
|
||
-- | The ways in which getting a reply from the server can fail.
|
||
--
|
||
-- An @EuphException@ may be raised by any function in the __API functions__ section.
|
||
data EuphException = EuphClosed
|
||
-- ^ Could not send message because connection was closed.
|
||
| EuphDisconnected
|
||
-- ^ Disconnected from server while waiting for the reply.
|
||
| EuphServerError T.Text
|
||
-- ^ The server replied with an error.
|
||
| EuphParse String BS.ByteString
|
||
-- ^ Could not parse the server's reply correctly.
|
||
|
||
instance Show EuphException where
|
||
show EuphClosed = "Connection already closed"
|
||
show EuphDisconnected = "Disconnected from server"
|
||
show (EuphServerError t) = "Server error: " ++ T.unpack t
|
||
show (EuphParse e bs) = "Parsing failed: " ++ e ++ " - packet was " ++ show bs
|
||
|
||
instance Exception EuphException
|
||
|
||
data Send = SDisconnect
|
||
| forall p . (ToJSON p) => SNoReply T.Text p -- packet type and contents
|
||
| forall p . (ToJSON p) => SReply T.Text p ReplyMVar
|
||
|
||
-- | The kinds of events that can occur in a 'Connection'.
|
||
-- For more information, see 'getEvent'.
|
||
data EventType = ConnectionFailed
|
||
-- ^ The @Connection@ failed to connect to that room.
|
||
-- When this event occurrs, no more events will occur.
|
||
| Disconnected
|
||
-- ^ The @Connection@ was closed.
|
||
-- When this event occurrs, no more events will occur.
|
||
| EuphEvent Event
|
||
-- ^ The server sent an 'Event'.
|
||
deriving (Show)
|
||
|
||
-- | Represents <http://api.euphoria.io/#asynchronous-events>.
|
||
--
|
||
-- These events may be sent from the server to the client at any time.
|
||
data Event
|
||
= 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)
|
||
deriving (Show)
|
||
|
||
-- LoginEvent -- not implemented
|
||
-- LogoutEvent -- not implemented
|
||
-- PMInitiateEvent -- not implemented
|
||
|
||
instance FromJSON Event 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 <$> (posixSecondsToUTCTime <$> o .: "time")
|
||
<*> (posixSecondsToUTCTime <$> o .: "next")
|
||
pSendEvent v = SendEvent <$> parseJSON v
|
||
pSnapshotEvent = withObject "SnapshotEvent" $ \o ->
|
||
SnapshotEvent <$> o .: "version" <*> o .: "listing" <*> o .: "log" <*> o .:? "nick"
|
||
|
||
(.?=) :: (ToJSON v, KeyValue kv) => T.Text -> Maybe v -> [kv]
|
||
k .?= (Just v) = [k .= v]
|
||
_ .?= Nothing = []
|
||
|
||
-- ping reply/command/whatever
|
||
|
||
newtype PingReplyCommand = PingReplyCommand
|
||
{ pingReplyCommandTime :: UTCTime
|
||
} deriving (Show)
|
||
|
||
instance ToJSON PingReplyCommand where
|
||
toJSON PingReplyCommand{..} =
|
||
object ["time" .= utcTimeToPOSIXSeconds pingReplyCommandTime]
|
||
|
||
-- auth command and reply
|
||
|
||
newtype AuthCommand = AuthCommand
|
||
{ authCommandPasscode :: T.Text
|
||
} deriving (Show)
|
||
|
||
instance ToJSON AuthCommand where
|
||
toJSON AuthCommand{..} =
|
||
object ["type" .= ("passcode" :: T.Text), "passcode" .= authCommandPasscode]
|
||
|
||
newtype AuthReply = AuthReply
|
||
{ authReplySuccess :: Maybe T.Text
|
||
} deriving (Show)
|
||
|
||
instance FromJSON AuthReply where
|
||
parseJSON = withObject "AuthReply" $ \o -> do
|
||
success <- o .: "success"
|
||
authReplySuccess <-
|
||
if success
|
||
then Just <$> o .: "reason"
|
||
else return Nothing
|
||
return AuthReply{..}
|
||
|
||
-- ping command and reply
|
||
|
||
newtype PingCommand = PingCommand
|
||
{ pingCommandTime :: UTCTime
|
||
} deriving (Show)
|
||
|
||
instance ToJSON PingCommand where
|
||
toJSON PingCommand{..} =
|
||
let timestr = show $ utcTimeToPOSIXSeconds pingCommandTime
|
||
in object ["time" .= timestr]
|
||
|
||
-- TODO: Maybe always return a "time"
|
||
newtype PingReply = PingReply
|
||
{ pingReplyTime :: Maybe UTCTime
|
||
} deriving (Show)
|
||
|
||
instance FromJSON PingReply where
|
||
parseJSON = withObject "PingReply" $ \o -> do
|
||
maybeTime <- o .:? "time"
|
||
let pingReplyTime = posixSecondsToUTCTime <$> maybeTime
|
||
return PingReply{..}
|
||
|
||
-- get-message command and reply
|
||
|
||
newtype GetMessageCommand = GetMessageCommand
|
||
{ getMessageCommandID :: E.Snowflake
|
||
} deriving (Show)
|
||
|
||
instance ToJSON GetMessageCommand where
|
||
toJSON GetMessageCommand{..} =
|
||
object ["id" .= getMessageCommandID]
|
||
|
||
newtype GetMessageReply = GetMessageReply
|
||
{ getMessageReplyMessage :: E.Message
|
||
} deriving (Show)
|
||
|
||
instance FromJSON GetMessageReply where
|
||
parseJSON v = GetMessageReply <$> parseJSON v
|
||
|
||
-- log command and reply
|
||
|
||
data LogCommand = LogCommand
|
||
{ logCommandN :: Integer
|
||
, logCommandBefore :: Maybe E.Snowflake
|
||
} deriving (Show)
|
||
|
||
instance ToJSON LogCommand where
|
||
toJSON LogCommand{..} =
|
||
object $ ("n" .= logCommandN) : ("before" .?= logCommandBefore)
|
||
|
||
-- TODO: Maybe omit the "before" if it's always the same as the one from the command?
|
||
-- TODO: Maybe always return a "before"?
|
||
data LogReply = LogReply
|
||
{ logReplyLog :: [E.Message]
|
||
, logReplyBefore :: Maybe E.Snowflake
|
||
} deriving (Show)
|
||
|
||
instance FromJSON LogReply where
|
||
parseJSON = withObject "LogReply" $ \o -> do
|
||
logReplyLog <- o .: "log"
|
||
logReplyBefore <- o .:? "before"
|
||
return LogReply{..}
|
||
|
||
-- 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
|
||
} deriving (Show)
|
||
|
||
instance ToJSON SendCommand where
|
||
toJSON SendCommand{..} =
|
||
object $ ("content" .= sendCommandContent) : ("parent" .?= sendCommandParent)
|
||
|
||
newtype SendReply = SendReply
|
||
{ sendReplyMessage :: E.Message
|
||
} deriving (Show)
|
||
|
||
instance FromJSON SendReply where
|
||
parseJSON v = SendReply <$> parseJSON v
|
||
|
||
-- who command and reply
|
||
|
||
data WhoCommand = WhoCommand
|
||
deriving (Show)
|
||
|
||
instance ToJSON WhoCommand where
|
||
toJSON WhoCommand = object []
|
||
|
||
newtype WhoReply = WhoReply
|
||
{ whoReplyListing :: [E.SessionView]
|
||
} deriving (Show)
|
||
|
||
instance FromJSON WhoReply where
|
||
parseJSON v = WhoReply <$> parseJSON v
|