Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add MonadIRC class #58

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions Network/IRC/Client.hs
Original file line number Diff line number Diff line change
Expand Up @@ -185,6 +185,7 @@ import Network.IRC.Client.Lens
import Network.IRC.Client.Utils hiding (fork)
import qualified Network.IRC.Client.Utils as U

import Control.Monad.Catch (MonadThrow)
import qualified Paths_irc_client as Paths


Expand Down Expand Up @@ -260,7 +261,7 @@ defaultInstanceConfig n = InstanceConfig

-- | Connect to the IRC server and run the client: receiving messages
-- and handing them off to handlers as appropriate.
runClient :: MonadIO m
runClient :: (MonadIO m, MonadThrow m)
=> ConnectionConfig s
-> InstanceConfig s
-> s
Expand All @@ -274,7 +275,7 @@ runClient cconf iconf ustate = newIRCState cconf iconf ustate >>= runClientWith
-- Multiple clients should not be run with the same 'IRCState'. The
-- utility of this is to be able to run @IRC s a@ actions in order to
-- interact with the client from the outside.
runClientWith :: MonadIO m => IRCState s -> m ()
runClientWith :: (MonadIO m, MonadThrow m) => IRCState s -> m ()
runClientWith = runIRCAction runner


Expand Down
18 changes: 9 additions & 9 deletions Network/IRC/Client/Events.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

Expand Down Expand Up @@ -44,14 +45,12 @@ module Network.IRC.Client.Events
, module Network.IRC.Conduit.Lens
) where

import Control.Applicative ((<$>), (<|>))
import Control.Applicative ((<|>))
import Control.Concurrent.STM (atomically, modifyTVar, readTVar)
import Control.Monad.Catch (SomeException, fromException,
throwM)
import Control.Monad.Catch (fromException, throwM)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isAlphaNum)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text, breakOn, takeEnd, toUpper)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
Expand Down Expand Up @@ -168,8 +167,8 @@ defaultEventHandlers =
]

-- | The default connect handler: set the nick.
defaultOnConnect :: IRC s ()
defaultOnConnect = do
defaultOnConnect :: ConnectHandler s
defaultOnConnect = ConnectHandler $ do
iconf <- snapshot instanceConfig =<< getIRCState
send . Nick $ get nick iconf

Expand All @@ -180,11 +179,12 @@ defaultOnConnect = do
-- - If the client disconnected due to another exception, rethrow it.
--
-- - If the client disconnected without an exception, halt.
defaultOnDisconnect :: Maybe SomeException -> IRC s ()
defaultOnDisconnect (Just exc) = case fromException exc of
defaultOnDisconnect :: DisconnectHandler s
defaultOnDisconnect = DisconnectHandler $ \case
(Just exc) -> case fromException exc of
Just Timeout -> reconnect
Nothing -> throwM exc
defaultOnDisconnect Nothing = pure ()
Nothing -> pure ()


-------------------------------------------------------------------------------
Expand Down
32 changes: 14 additions & 18 deletions Network/IRC/Client/Internal.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module : Network.IRC.Client.Internal
Expand All @@ -22,7 +23,6 @@ module Network.IRC.Client.Internal
, module Network.IRC.Client.Internal.Types
) where

import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, killThread,
myThreadId, threadDelay,
throwTo)
Expand All @@ -33,9 +33,9 @@ import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan,
isEmptyTBMChan, newTBMChan,
readTBMChan, writeTBMChan)
import Control.Monad (forM_, unless, void, when)
import Control.Monad.Catch (SomeException, catch)
import Control.Monad.Catch (SomeException, catch, MonadThrow)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ask, runReaderT)
import Control.Monad.Reader (runReaderT)
import Data.ByteString (ByteString, isPrefixOf)
import Data.Conduit (ConduitM, await,
awaitForever, yield, (.|))
Expand Down Expand Up @@ -72,9 +72,9 @@ import Network.IRC.Client.Lens
setupInternal
:: (IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ())
-- ^ Function to start the network conduits.
-> IRC s ()
-> ConnectHandler s
-- ^ Connect handler
-> (Maybe SomeException -> IRC s ())
-> DisconnectHandler s
-- ^ Disconnect handler
-> (Origin -> ByteString -> IO ())
-- ^ Logging function
Expand Down Expand Up @@ -102,7 +102,7 @@ setupInternal f oncon ondis logf host port_ = ConnectionConfig
-- * Event loop

-- | The event loop.
runner :: IRC s ()
runner :: MonadIRC s m => m ()
runner = do
state <- getIRCState
let cconf = _connectionConfig state
Expand All @@ -117,7 +117,7 @@ runner = do
liftIO . atomically $ writeTVar (_connectionState state) Connected
mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) thePass
sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal]
_onconnect cconf
runConnectHandler $ _onconnect cconf

-- Run the event loop, and call the disconnect handler if the remote
-- end closes the socket.
Expand Down Expand Up @@ -153,7 +153,7 @@ runner = do
(pure . Just)

disconnect
_ondisconnect cconf exc
runDisconnectHandler (_ondisconnect cconf) exc

-- | Forget failed decodings.
forgetful :: Monad m => ConduitM (Either a b) b m ()
Expand Down Expand Up @@ -243,12 +243,12 @@ concealPass m = m

-- | Send a message as UTF-8, using TLS if enabled. This blocks if
-- messages are sent too rapidly.
send :: Message Text -> IRC s ()
send :: MonadIRC s m => Message Text -> m ()
send = sendBS . fmap encodeUtf8

-- | Send a message, using TLS if enabled. This blocks if messages are
-- sent too rapidly.
sendBS :: Message ByteString -> IRC s ()
sendBS :: MonadIRC s m => Message ByteString -> m ()
sendBS msg = do
qv <- _sendqueue <$> getIRCState
liftIO . atomically $ flip writeTBMChan msg =<< readTVar qv
Expand All @@ -259,7 +259,7 @@ sendBS msg = do

-- | Disconnect from the server, properly tearing down the TLS session
-- (if there is one).
disconnect :: IRC s ()
disconnect :: MonadIRC s m => m ()
disconnect = do
s <- getIRCState

Expand Down Expand Up @@ -298,7 +298,7 @@ disconnect = do
--
-- Like 'runClient' and 'runClientWith', this will not return until
-- the client terminates (ie, disconnects without reconnecting).
reconnect :: IRC s ()
reconnect :: MonadIRC s m => m ()
reconnect = do
disconnect

Expand All @@ -314,12 +314,8 @@ reconnect = do
-- * Utils

-- | Interact with a client from the outside, by using its 'IRCState'.
runIRCAction :: MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction ma = liftIO . runReaderT (runIRC ma)

-- | Access the client state.
getIRCState :: IRC s (IRCState s)
getIRCState = ask
runIRCAction :: (MonadIO m, MonadThrow m) => IRCT s m a -> IRCState s -> m a
runIRCAction ma = runReaderT (runIRCT ma)

-- | Get the connection state from an IRC state.
getConnectionState :: IRCState s -> STM ConnectionState
Expand Down
51 changes: 41 additions & 10 deletions Network/IRC/Client/Internal/Types.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,11 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module : Network.IRC.Client.Internal.Types
Expand All @@ -26,9 +30,9 @@ import Control.Monad (MonadPlus)
import Control.Monad.Catch (Exception, MonadCatch,
MonadMask, MonadThrow,
SomeException)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT, asks)
import Control.Monad.Reader (MonadReader, ReaderT, ask)
import Control.Monad.State (MonadState(..))
import Control.Monad.Trans
import Data.ByteString (ByteString)
import Data.Conduit (ConduitM)
import qualified Data.Set as S
Expand All @@ -42,21 +46,38 @@ import Network.IRC.Conduit (Event(..), Message, Source)
-- * The IRC monad

-- | The IRC monad.
newtype IRC s a = IRC { runIRC :: ReaderT (IRCState s) IO a }
type IRC s a = IRCT s IO a

-- | The IRC monad transformer
newtype IRCT s m a = IRCT { runIRCT :: ReaderT (IRCState s) m a }
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader (IRCState s), MonadThrow, MonadCatch, MonadMask)

instance MonadState s (IRC s) where
instance MonadTrans (IRCT s) where
lift = IRCT . lift

-- | mtl style class for IRC monad
class (MonadIO m, MonadThrow m) => MonadIRC s m | m -> s where
-- | Access the client state.
getIRCState :: m (IRCState s)

instance (MonadIO m, MonadThrow m) => MonadIRC s (IRCT s m) where
getIRCState = ask

-- | Add MonadState instances for each MonadIRC monad
--
-- This enables orphan instances
instance (Monad m, MonadIRC s m) => MonadState s m where
state f = do
tvar <- asks _userState
tvar <- _userState <$> getIRCState
liftIO . atomically $ do
(a, s) <- f <$> readTVar tvar
writeTVar tvar s
pure a
get = do
tvar <- asks _userState
tvar <- _userState <$> getIRCState
liftIO $ readTVarIO tvar
put s = do
tvar <- asks _userState
tvar <- _userState <$> getIRCState
liftIO $ atomically (writeTVar tvar s)

-------------------------------------------------------------------------------
Expand All @@ -78,6 +99,16 @@ data IRCState s = IRCState
-- ^ Threads which will be killed when the client disconnects.
}

-- | On connect handler in 'ConnectionConfig'
--
-- GHC does not support impredicative types, so we need wrap forall into a newtype.
newtype ConnectHandler s = ConnectHandler { runConnectHandler :: forall m. MonadIRC s m => m () }

-- | On disconnect handler in 'ConnectionConfig'
--
-- GHC does not support impredicative types, so we need wrap forall into a newtype.
newtype DisconnectHandler s = DisconnectHandler { runDisconnectHandler :: forall m. MonadIRC s m => Maybe SomeException -> m () }

-- | The static state of an IRC server connection.
data ConnectionConfig s = ConnectionConfig
{ _func :: IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ()
Expand All @@ -98,10 +129,10 @@ data ConnectionConfig s = ConnectionConfig
-- ^ The maximum time (in seconds) between received messages from
-- the server. If no messages arrive from the server for this
-- period, the client is sent a 'Timeout' exception and disconnects.
, _onconnect :: IRC s ()
, _onconnect :: ConnectHandler s
-- ^ Action to run after sending the @PASS@ and @USER@ commands to the
-- server. The default behaviour is to send the @NICK@ command.
, _ondisconnect :: Maybe SomeException -> IRC s ()
, _ondisconnect :: DisconnectHandler s
-- ^ Action to run after disconnecting from the server, both by
-- local choice and by losing the connection. This is run after
-- tearing down the connection. If the connection terminated due to
Expand Down Expand Up @@ -146,7 +177,7 @@ data Origin = FromServer | FromClient
data EventHandler s where
EventHandler
:: (Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ())
-> (forall m. MonadIRC s m => Source Text -> b -> m ())
-> EventHandler s


Expand Down
7 changes: 4 additions & 3 deletions Network/IRC/Client/Lens.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
{-# LANGUAGE RankNTypes #-}

-- |
-- Module : Network.IRC.Client.Lens
-- Copyright : (c) 2017 Michael Walker
Expand All @@ -10,7 +12,6 @@
module Network.IRC.Client.Lens where

import Control.Concurrent.STM (TVar)
import Control.Monad.Catch (SomeException)
import Data.ByteString (ByteString)
import Data.Profunctor (Choice(right'),
Profunctor(dimap))
Expand Down Expand Up @@ -111,12 +112,12 @@ timeout = \ afb s -> (\ b -> s {_timeout = b}) <$> afb (_timeout s)

{-# INLINE onconnect #-}
{-| 'Lens' for '_onconnect'. -}
onconnect :: Lens' (ConnectionConfig s) (IRC s ())
onconnect :: Lens' (ConnectionConfig s) (ConnectHandler s)
onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s)

{-# INLINE ondisconnect #-}
{-| 'Lens' for '_ondisconnect'. -}
ondisconnect :: Lens' (ConnectionConfig s) (Maybe SomeException -> IRC s ())
ondisconnect :: Lens' (ConnectionConfig s) (DisconnectHandler s)
ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s)

{-# INLINE logfunc #-}
Expand Down
Loading