Garmelon/haboli
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement catch

Browse source
This commit is contained in:
Joscha 2020-01-06 17:55:39 +00:00
parent 3dbed10ffd
commit fa15162620
1 changed files with 11 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

16
src/Haboli/Euphoria/Client.hs
View file

@ -21,6 +21,7 @@ module Haboli.Euphoria.Client
-- ** Exception handling -- ** Exception handling
, ClientException(..) , ClientException(..)
, Haboli.Euphoria.Client.throw , Haboli.Euphoria.Client.throw
, Haboli.Euphoria.Client.catch
-- ** Euphoria commands -- ** Euphoria commands
-- *** Session commands -- *** Session commands
, pingReply , pingReply
@ -111,8 +112,8 @@ data ClientInfo e = ClientInfo
} }
-- This type declaration feels lispy in its parenthesisness -- This type declaration feels lispy in its parenthesisness
newtype Client e a = Client (ReaderT (ClientInfo e) newtype Client e a = Client (ExceptT (ClientException e)
(ExceptT (ClientException e) (ReaderT (ClientInfo e)
IO) a) IO) a)
deriving (Functor, Applicative, Monad, MonadIO) deriving (Functor, Applicative, Monad, MonadIO)
@ -208,7 +209,7 @@ runClient details (Client stack)
wsThreadFinished <- newEmptyMVar wsThreadFinished <- newEmptyMVar
void $ forkFinally (runWebsocketThread info) (\_ -> putMVar wsThreadFinished ()) void $ forkFinally (runWebsocketThread info) (\_ -> putMVar wsThreadFinished ())
-- Run the actual 'Client' in this thread -- Run the actual 'Client' in this thread
result <- runExceptT $ runReaderT stack info result <- runReaderT (runExceptT stack) info
-- Close the connection if it is not already closed, and wait until the -- Close the connection if it is not already closed, and wait until the
-- websocket thread stops -- websocket thread stops
handle ignoreAllExceptions $ WS.sendClose connection $ T.pack "Goodbye :D" handle ignoreAllExceptions $ WS.sendClose connection $ T.pack "Goodbye :D"
@ -221,10 +222,10 @@ runClient details (Client stack)
{- Private operations -} {- Private operations -}
throwRaw :: ClientException e -> Client e a throwRaw :: ClientException e -> Client e a
throwRaw e = Client $ lift $ throwE e throwRaw = Client . throwE
getClientInfo :: Client e (ClientInfo e) getClientInfo :: Client e (ClientInfo e)
getClientInfo = Client ask getClientInfo = Client $ lift ask
newPacketId :: Client e T.Text newPacketId :: Client e T.Text
newPacketId = do newPacketId = do
@ -328,6 +329,11 @@ respondingToPing holdingEvent = do
throw :: e -> Client e a throw :: e -> Client e a
throw = throwRaw . CustomException 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
{- Euphoria commands -} {- Euphoria commands -}
{- Session commands -} {- Session commands -}