Reorder stuff to better match the documentation structure
This commit is contained in:
parent
e578d688ab
commit
1908a050c9
1 changed files with 134 additions and 137 deletions
|
|
@ -60,69 +60,6 @@ import qualified Wuss as WSS
|
||||||
|
|
||||||
import Haboli.Euphoria.Api
|
import Haboli.Euphoria.Api
|
||||||
|
|
||||||
--TODO: Add all the events
|
|
||||||
data Event
|
|
||||||
= EventBounce BounceEvent
|
|
||||||
| EventDisconnect DisconnectEvent
|
|
||||||
| EventHello HelloEvent
|
|
||||||
| EventJoin JoinEvent
|
|
||||||
| EventLogin LoginEvent
|
|
||||||
| EventLogout LogoutEvent
|
|
||||||
| EventNetwork NetworkEvent
|
|
||||||
| EventNick NickEvent
|
|
||||||
| EventEditMessage EditMessageEvent
|
|
||||||
| EventPart PartEvent
|
|
||||||
| EventPing PingEvent
|
|
||||||
| EventPmInitiate PmInitiateEvent
|
|
||||||
| EventSend SendEvent
|
|
||||||
| EventSnapshot SnapshotEvent
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
instance FromJSON Event where
|
|
||||||
parseJSON v = foldr (<|>) mempty
|
|
||||||
[ EventJoin <$> parseJSON v
|
|
||||||
, EventPart <$> parseJSON v
|
|
||||||
, EventPing <$> parseJSON v
|
|
||||||
, EventSend <$> parseJSON v
|
|
||||||
, EventSnapshot <$> parseJSON v
|
|
||||||
]
|
|
||||||
|
|
||||||
data ClientException e
|
|
||||||
= ServerException T.Text
|
|
||||||
-- ^ @'ServerError' error@ is an error sent by the server in response to a
|
|
||||||
-- command. @error@ is a message that appears if a command fails.
|
|
||||||
| StoppedException
|
|
||||||
| DecodeException T.Text
|
|
||||||
-- ^ At some point during decoding a websocket packet, something went wrong.
|
|
||||||
| UnexpectedException SomeException
|
|
||||||
-- ^ While a forked thread was executed, an unexpected exception was thrown in
|
|
||||||
-- the IO monad.
|
|
||||||
| CustomException e
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
-- | A server's reply to a command.
|
|
||||||
data Reply e r = Reply
|
|
||||||
{ replyThrottled :: Maybe T.Text
|
|
||||||
, replyResult :: Either (ClientException e) r
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
instance FromJSON r => FromJSON (Reply e r) where
|
|
||||||
parseJSON v@(Object o) = Reply
|
|
||||||
<$> throttledParser
|
|
||||||
<*> ((Left <$> errorParser) <|> (Right <$> parseJSON v))
|
|
||||||
where
|
|
||||||
throttledParser = do
|
|
||||||
throttled <- o .:? "throttled" .!= False
|
|
||||||
if throttled
|
|
||||||
then Just <$> o .:? "throttled_reason" .!= ""
|
|
||||||
else pure Nothing
|
|
||||||
errorParser = ServerException <$> o .: "error"
|
|
||||||
parseJSON v = typeMismatch "Object" v
|
|
||||||
|
|
||||||
emptyReply :: Either (ClientException e) r -> Reply e r
|
|
||||||
emptyReply = Reply Nothing
|
|
||||||
|
|
||||||
-- | This type represents a @'Reply' e r@ with arbitrary @r@ that has yet to be
|
-- | This type represents a @'Reply' e r@ with arbitrary @r@ that has yet to be
|
||||||
-- received. The @forall@ allows whoever creates the 'AwaitingReply' to decide
|
-- received. The @forall@ allows whoever creates the 'AwaitingReply' to decide
|
||||||
-- on the type of @r@.
|
-- on the type of @r@.
|
||||||
|
|
@ -191,6 +128,7 @@ parseAndSendReply msg awaiting = do
|
||||||
parsePacketId (Object o) = o .: "id"
|
parsePacketId (Object o) = o .: "id"
|
||||||
parsePacketId v = typeMismatch "Object" v
|
parsePacketId v = typeMismatch "Object" v
|
||||||
|
|
||||||
|
--TODO: Decode to 'Value' only once. After that, just apply the parsers.
|
||||||
runWebsocketThread :: ClientInfo e -> IO ()
|
runWebsocketThread :: ClientInfo e -> IO ()
|
||||||
runWebsocketThread info
|
runWebsocketThread info
|
||||||
= WS.withPingThread (ciConnection info) pingInterval (pure ())
|
= WS.withPingThread (ciConnection info) pingInterval (pure ())
|
||||||
|
|
@ -254,13 +192,143 @@ runClient details (Client stack)
|
||||||
ignoreAllExceptions :: WS.ConnectionException -> IO ()
|
ignoreAllExceptions :: WS.ConnectionException -> IO ()
|
||||||
ignoreAllExceptions _ = pure ()
|
ignoreAllExceptions _ = pure ()
|
||||||
|
|
||||||
{- Private operations -}
|
{- Getters -}
|
||||||
|
|
||||||
|
getClientInfo :: Client e (ClientInfo e)
|
||||||
|
getClientInfo = Client $ lift ask
|
||||||
|
|
||||||
|
getHost :: Client e HostName
|
||||||
|
getHost = cdHost . ciDetails <$> getClientInfo
|
||||||
|
|
||||||
|
getPort :: Client e PortNumber
|
||||||
|
getPort = cdPort . ciDetails <$> getClientInfo
|
||||||
|
|
||||||
|
getPath :: Client e String
|
||||||
|
getPath = cdPath . ciDetails <$> getClientInfo
|
||||||
|
|
||||||
|
{- Event handling -}
|
||||||
|
|
||||||
|
data Event
|
||||||
|
= EventBounce BounceEvent
|
||||||
|
| EventDisconnect DisconnectEvent
|
||||||
|
| EventHello HelloEvent
|
||||||
|
| EventJoin JoinEvent
|
||||||
|
| EventLogin LoginEvent
|
||||||
|
| EventLogout LogoutEvent
|
||||||
|
| EventNetwork NetworkEvent
|
||||||
|
| EventNick NickEvent
|
||||||
|
| EventEditMessage EditMessageEvent
|
||||||
|
| EventPart PartEvent
|
||||||
|
| EventPing PingEvent
|
||||||
|
| EventPmInitiate PmInitiateEvent
|
||||||
|
| EventSend SendEvent
|
||||||
|
| EventSnapshot SnapshotEvent
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
--TODO: Add all the events
|
||||||
|
instance FromJSON Event where
|
||||||
|
parseJSON v = foldr (<|>) mempty
|
||||||
|
[ EventJoin <$> parseJSON v
|
||||||
|
, EventPart <$> parseJSON v
|
||||||
|
, EventPing <$> parseJSON v
|
||||||
|
, EventSend <$> parseJSON v
|
||||||
|
, EventSnapshot <$> parseJSON v
|
||||||
|
]
|
||||||
|
|
||||||
|
nextEvent :: Client e Event
|
||||||
|
nextEvent = do
|
||||||
|
info <- getClientInfo
|
||||||
|
exceptionOrEvent <- liftIO $ atomically $ do
|
||||||
|
stopped <- readTVar (ciStopped info)
|
||||||
|
if stopped
|
||||||
|
then pure $ Left StoppedException
|
||||||
|
else Right <$> readTChan (ciEventChan info)
|
||||||
|
case exceptionOrEvent of
|
||||||
|
Left e -> throwRaw e
|
||||||
|
Right e -> pure e
|
||||||
|
|
||||||
|
respondingToPing :: Client e Event -> Client e Event
|
||||||
|
respondingToPing holdingEvent = do
|
||||||
|
event <- holdingEvent
|
||||||
|
case event of
|
||||||
|
EventPing e -> pingReply (pingTime e)
|
||||||
|
_ -> pure ()
|
||||||
|
pure event
|
||||||
|
|
||||||
|
{- Exception handling -}
|
||||||
|
|
||||||
|
data ClientException e
|
||||||
|
= ServerException T.Text
|
||||||
|
-- ^ @'ServerError' error@ is an error sent by the server in response to a
|
||||||
|
-- command. @error@ is a message that appears if a command fails.
|
||||||
|
| StoppedException
|
||||||
|
| DecodeException T.Text
|
||||||
|
-- ^ At some point during decoding a websocket packet, something went wrong.
|
||||||
|
| UnexpectedException SomeException
|
||||||
|
-- ^ While a forked thread was executed, an unexpected exception was thrown in
|
||||||
|
-- the IO monad.
|
||||||
|
| CustomException e
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
throwRaw :: ClientException e -> Client e a
|
throwRaw :: ClientException e -> Client e a
|
||||||
throwRaw = Client . throwE
|
throwRaw = Client . throwE
|
||||||
|
|
||||||
getClientInfo :: Client e (ClientInfo e)
|
throw :: e -> Client e a
|
||||||
getClientInfo = Client $ lift ask
|
throw = throwRaw . CustomException
|
||||||
|
|
||||||
|
catch :: Client e a -> (ClientException e -> Client e a) -> Client e a
|
||||||
|
catch c f = Client $ catchE (unclient c) (unclient . f)
|
||||||
|
where
|
||||||
|
unclient (Client m) = m
|
||||||
|
|
||||||
|
handle :: (ClientException e -> Client e a) -> Client e a -> Client e a
|
||||||
|
handle = flip Haboli.Euphoria.Client.catch
|
||||||
|
|
||||||
|
{- Threading -}
|
||||||
|
|
||||||
|
newtype Thread e a = Thread (MVar (Either (ClientException e) a))
|
||||||
|
|
||||||
|
fork :: Client e a -> Client e (Thread e a)
|
||||||
|
fork (Client f) = do
|
||||||
|
info <- getClientInfo
|
||||||
|
waitVar <- liftIO newEmptyMVar
|
||||||
|
let thread = runReaderT (runExceptT f) info
|
||||||
|
andThen (Left e) = putMVar waitVar $ Left $ UnexpectedException e
|
||||||
|
andThen (Right r) = putMVar waitVar r
|
||||||
|
void $ liftIO $ forkFinally thread andThen
|
||||||
|
pure $ Thread waitVar
|
||||||
|
|
||||||
|
wait :: Thread e a -> Client e a
|
||||||
|
wait (Thread waitVar) = do
|
||||||
|
result <- liftIO $ readMVar waitVar
|
||||||
|
case result of
|
||||||
|
(Left e) -> throwRaw e
|
||||||
|
(Right a) -> pure a
|
||||||
|
|
||||||
|
{- Euphoria commands -}
|
||||||
|
|
||||||
|
-- | A server's reply to a command.
|
||||||
|
data Reply e r = Reply
|
||||||
|
{ replyThrottled :: Maybe T.Text
|
||||||
|
, replyResult :: Either (ClientException e) r
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
instance FromJSON r => FromJSON (Reply e r) where
|
||||||
|
parseJSON v@(Object o) = Reply
|
||||||
|
<$> throttledParser
|
||||||
|
<*> ((Left <$> errorParser) <|> (Right <$> parseJSON v))
|
||||||
|
where
|
||||||
|
throttledParser = do
|
||||||
|
throttled <- o .:? "throttled" .!= False
|
||||||
|
if throttled
|
||||||
|
then Just <$> o .:? "throttled_reason" .!= ""
|
||||||
|
else pure Nothing
|
||||||
|
errorParser = ServerException <$> o .: "error"
|
||||||
|
parseJSON v = typeMismatch "Object" v
|
||||||
|
|
||||||
|
emptyReply :: Either (ClientException e) r -> Reply e r
|
||||||
|
emptyReply = Reply Nothing
|
||||||
|
|
||||||
newPacketId :: Client e T.Text
|
newPacketId :: Client e T.Text
|
||||||
newPacketId = do
|
newPacketId = do
|
||||||
|
|
@ -322,77 +390,6 @@ sendPacketWithReply packet = do
|
||||||
Left e -> throwRaw e
|
Left e -> throwRaw e
|
||||||
Right r -> pure r
|
Right r -> pure r
|
||||||
|
|
||||||
{- Public operations -}
|
|
||||||
|
|
||||||
{- Getters -}
|
|
||||||
|
|
||||||
getHost :: Client e HostName
|
|
||||||
getHost = cdHost . ciDetails <$> getClientInfo
|
|
||||||
|
|
||||||
getPort :: Client e PortNumber
|
|
||||||
getPort = cdPort . ciDetails <$> getClientInfo
|
|
||||||
|
|
||||||
getPath :: Client e String
|
|
||||||
getPath = cdPath . ciDetails <$> getClientInfo
|
|
||||||
|
|
||||||
{- Event handling -}
|
|
||||||
|
|
||||||
nextEvent :: Client e Event
|
|
||||||
nextEvent = do
|
|
||||||
info <- getClientInfo
|
|
||||||
exceptionOrEvent <- liftIO $ atomically $ do
|
|
||||||
stopped <- readTVar (ciStopped info)
|
|
||||||
if stopped
|
|
||||||
then pure $ Left StoppedException
|
|
||||||
else Right <$> readTChan (ciEventChan info)
|
|
||||||
case exceptionOrEvent of
|
|
||||||
Left e -> throwRaw e
|
|
||||||
Right e -> pure e
|
|
||||||
|
|
||||||
respondingToPing :: Client e Event -> Client e Event
|
|
||||||
respondingToPing holdingEvent = do
|
|
||||||
event <- holdingEvent
|
|
||||||
case event of
|
|
||||||
EventPing e -> pingReply (pingTime e)
|
|
||||||
_ -> pure ()
|
|
||||||
pure event
|
|
||||||
|
|
||||||
{- Exception handling -}
|
|
||||||
|
|
||||||
throw :: e -> Client e a
|
|
||||||
throw = throwRaw . CustomException
|
|
||||||
|
|
||||||
catch :: Client e a -> (ClientException e -> Client e a) -> Client e a
|
|
||||||
catch c f = Client $ catchE (unclient c) (unclient . f)
|
|
||||||
where
|
|
||||||
unclient (Client m) = m
|
|
||||||
|
|
||||||
handle :: (ClientException e -> Client e a) -> Client e a -> Client e a
|
|
||||||
handle = flip Haboli.Euphoria.Client.catch
|
|
||||||
|
|
||||||
{- Threading -}
|
|
||||||
|
|
||||||
newtype Thread e a = Thread (MVar (Either (ClientException e) a))
|
|
||||||
|
|
||||||
fork :: Client e a -> Client e (Thread e a)
|
|
||||||
fork (Client f) = do
|
|
||||||
info <- getClientInfo
|
|
||||||
waitVar <- liftIO newEmptyMVar
|
|
||||||
let thread = runReaderT (runExceptT f) info
|
|
||||||
andThen (Left e) = putMVar waitVar $ Left $ UnexpectedException e
|
|
||||||
andThen (Right r) = putMVar waitVar r
|
|
||||||
void $ liftIO $ forkFinally thread andThen
|
|
||||||
pure $ Thread waitVar
|
|
||||||
|
|
||||||
wait :: Thread e a -> Client e a
|
|
||||||
wait (Thread waitVar) = do
|
|
||||||
result <- liftIO $ readMVar waitVar
|
|
||||||
case result of
|
|
||||||
(Left e) -> throwRaw e
|
|
||||||
(Right a) -> pure a
|
|
||||||
|
|
||||||
{- Euphoria commands -}
|
|
||||||
|
|
||||||
{- Session commands -}
|
{- Session commands -}
|
||||||
|
|
||||||
pingReply :: UTCTime -> Client e ()
|
pingReply :: UTCTime -> Client e ()
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue