diff options
Diffstat (limited to 'vendor/irc-client/Network/IRC/Client/Internal')
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Internal/Lens.hs | 88 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Internal/Types.hs | 168 |
2 files changed, 256 insertions, 0 deletions
diff --git a/vendor/irc-client/Network/IRC/Client/Internal/Lens.hs b/vendor/irc-client/Network/IRC/Client/Internal/Lens.hs new file mode 100644 index 0000000..783aa63 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Internal/Lens.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Client.Internal.Lens +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : CPP, ImpredicativeTypes +-- +-- Types and functions for dealing with optics without depending on +-- the lens library. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal.Lens where + +import Control.Applicative (Const(..)) +import Control.Concurrent.STM (STM, TVar, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Functor.Contravariant (Contravariant) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid (First(..)) +import Data.Profunctor (Choice) + + +------------------------------------------------------------------------------- +-- * Internal lens synonyms + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getter Control.Lens.Getter.Getter>@. +type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getting Control.Lens.Getter.Getting>@. +type Getting r s a = (a -> Const r a) -> s -> Const r s + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Prism'. +type Prism' s a = Prism s s a a + + +------------------------------------------------------------------------------- +-- * Utilities + +-- | Get a value from a lens. +{-# INLINE get #-} +get :: Getting a s a -> s -> a +get lens = getConst . lens Const + +-- | Set a value in a lens. +{-# INLINE set #-} +set :: Lens' s a -> a -> s -> s +set lens a = runIdentity . lens (\_ -> Identity a) + +-- | Modify a value in a lens. +{-# INLINE modify #-} +modify :: Lens' s a -> (a -> a) -> s -> s +modify lens f s = let a = get lens s in set lens (f a) s + +-- | Read a value from a prism. +{-# INLINE preview #-} +preview :: Prism' s a -> s -> Maybe a +preview lens = getFirst . getConst . lens (Const . First . Just) + + +------------------------------------------------------------------------------- +-- ** STM + +-- | Atomically snapshot some shared state. +snapshot :: MonadIO m => Getting (TVar a) s (TVar a) -> s -> m a +snapshot lens = liftIO . readTVarIO . get lens + +-- | Atomically snapshot and modify some shared state. +snapshotModify :: MonadIO m => Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b +snapshotModify lens f s = liftIO . atomically $ do + let avar = get lens s + a <- readTVar avar + (a', b) <- f a + writeTVar avar a' + pure b diff --git a/vendor/irc-client/Network/IRC/Client/Internal/Types.hs b/vendor/irc-client/Network/IRC/Client/Internal/Types.hs new file mode 100644 index 0000000..73fbf14 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Internal/Types.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Network.IRC.Client.Internal.Types +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses +-- +-- Internal types. Most of these are re-exported elsewhere as lenses. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal.Types where + +import Control.Applicative (Alternative) +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM (TVar, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Concurrent.STM.TBMChan (TBMChan) +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.State (MonadState(..)) +import Data.ByteString (ByteString) +import Data.Conduit (ConduitM) +import qualified Data.Set as S +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime) +import Data.Void (Void) +import Network.IRC.Conduit (Event(..), Message, Source) + + +------------------------------------------------------------------------------- +-- * The IRC monad + +-- | The IRC monad. +newtype IRC s a = IRC { runIRC :: ReaderT (IRCState s) IO a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader (IRCState s), MonadThrow, MonadCatch, MonadMask) + +instance MonadState s (IRC s) where + state f = do + tvar <- asks _userState + liftIO . atomically $ do + (a, s) <- f <$> readTVar tvar + writeTVar tvar s + pure a + get = do + tvar <- asks _userState + liftIO $ readTVarIO tvar + put s = do + tvar <- asks _userState + liftIO $ atomically (writeTVar tvar s) + +------------------------------------------------------------------------------- +-- * State + +-- | The state of an IRC session. +data IRCState s = IRCState + { _connectionConfig :: ConnectionConfig s + -- ^ Read-only connection configuration + , _userState :: TVar s + -- ^ Mutable user state + , _instanceConfig :: TVar (InstanceConfig s) + -- ^ Mutable instance configuration in STM + , _sendqueue :: TVar (TBMChan (Message ByteString)) + -- ^ Message send queue. + , _connectionState :: TVar ConnectionState + -- ^ State of the connection. + , _runningThreads :: TVar (S.Set ThreadId) + -- ^ Threads which will be killed when the client disconnects. + } + +-- | 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 () + -- ^ Function to connect and start the conduits. + , _server :: ByteString + -- ^ The server host. + , _port :: Int + -- ^ The server port. + , _username :: Text + -- ^ Client username; sent to the server during the initial set-up. + , _realname :: Text + -- ^ Client realname; sent to the server during the initial set-up. + , _password :: Maybe Text + -- ^ Client password; sent to the server during the initial set-up. + , _flood :: NominalDiffTime + -- ^ The minimum time between two adjacent messages. + , _timeout :: NominalDiffTime + -- ^ 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 () + -- ^ 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 () + -- ^ 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 + -- an exception, it is given. The default behaviour is to reconnect + -- if a timeout, otherwise rethrow any exception. + , _logfunc :: Origin -> ByteString -> IO () + -- ^ Function to log messages sent to and received from the server. + } + +-- | The updateable state of an IRC connection. +data InstanceConfig s = InstanceConfig + { _nick :: Text + -- ^ Client nick + , _channels :: [Text] + -- ^ Current channels: this list both determines the channels to join on + -- connect, and is modified by the default event handlers when channels + -- are joined or parted. + , _version :: Text + -- ^ The version is sent in response to the CTCP \"VERSION\" request by + -- the default event handlers. + , _handlers :: [EventHandler s] + -- ^ The registered event handlers. The order in this list is the + -- order in which they are executed. + , _ignore :: [(Text, Maybe Text)] + -- ^ List of nicks (optionally restricted to channels) to ignore + -- messages from. 'Nothing' ignores globally. + } + +-- | The state of the connection. +data ConnectionState = Connected | Disconnecting | Disconnected + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | The origin of a message. +data Origin = FromServer | FromClient + deriving (Bounded, Enum, Eq, Ord, Read, Show) + + +------------------------------------------------------------------------------- +-- * Events + +-- | A function which handles an event. +data EventHandler s where + EventHandler + :: (Event Text -> Maybe b) + -> (Source Text -> b -> IRC s ()) + -> EventHandler s + + +------------------------------------------------------------------------------- +-- * Exceptions + +-- | Exception thrown to kill the client if the timeout elapses with +-- nothing received from the server. +data Timeout = Timeout + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Exception Timeout + +-- | Exception thrown to all managed threads when the client +-- disconnects. +data Disconnect = Disconnect + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Exception Disconnect |