diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -1,7 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} --- | A simple IRC client library. Typical usage will be of this form: +-- | +-- Module : Network.IRC.Client +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : OverloadedStrings -- +-- A simple IRC client library. Typical usage will be of this form: +-- -- > run :: ByteString -> Int -> Text -> IO () -- > run host port nick = do -- > conn <- connect host port 1 @@ -16,6 +24,8 @@ ( -- * Initialisation connect , connectWithTLS + , connectWithTLSConfig + , connectWithTLSVerify , start , start' , startStateful @@ -24,6 +34,8 @@ , Origin (..) , connect' , connectWithTLS' + , connectWithTLSConfig' + , connectWithTLSVerify' , stdoutLogger , fileLogger , noopLogger @@ -44,20 +56,26 @@ -- * Utilities , module Network.IRC.Client.Utils - , rawMessage - , toByteString + , C.rawMessage + , C.toByteString ) where import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (runReaderT) import Data.ByteString (ByteString) +import qualified Data.Conduit.Network.TLS as TLS import Data.Text (Text) import Data.Time.Clock (NominalDiffTime) +import qualified Data.X509 as X +import qualified Data.X509.CertificateStore as X +import qualified Data.X509.Validation as X +import qualified Network.Connection as TLS (TLSSettings(..)) import Network.IRC.Client.Handlers import Network.IRC.Client.Internal import Network.IRC.Client.Types import Network.IRC.Client.Utils -import Network.IRC.Conduit (ircClient, ircTLSClient, rawMessage, toByteString) +import qualified Network.IRC.Conduit as C +import qualified Network.TLS as TLS -- * Connecting to an IRC network @@ -83,6 +101,30 @@ -> m (ConnectionConfig s) connectWithTLS = connectWithTLS' noopLogger +-- | Connect to a server with TLS using the given TLS config. +connectWithTLSConfig :: MonadIO m + => TLS.TLSClientConfig + -- ^ The TLS config + -> NominalDiffTime + -- ^ The flood cooldown + -> m (ConnectionConfig s) +connectWithTLSConfig = connectWithTLSConfig' noopLogger + +-- | Connect to a server with TLS using the given certificate +-- verifier. +connectWithTLSVerify :: MonadIO m + => (X.CertificateStore -> TLS.ValidationCache -> X.ServiceID -> X.CertificateChain -> IO [X.FailedReason]) + -- ^ The certificate verifier. Returns an empty list if the cert is + -- good. + -> ByteString + -- ^ The hostname + -> Int + -- ^ The port + -> NominalDiffTime + -- ^ The flood cooldown + -> m (ConnectionConfig s) +connectWithTLSVerify = connectWithTLSVerify' noopLogger + -- | Connect to a server without TLS, with the provided logging -- function. connect' :: MonadIO m @@ -95,7 +137,8 @@ -> NominalDiffTime -- ^ The flood cooldown -> m (ConnectionConfig s) -connect' = connectInternal ircClient defaultOnConnect defaultOnDisconnect +connect' lg host port = + connectInternal (C.ircClient port host) defaultOnConnect defaultOnDisconnect lg host port -- | Connect to a server with TLS, with the provided logging function. connectWithTLS' :: MonadIO m @@ -108,8 +151,55 @@ -> NominalDiffTime -- ^ The flood cooldown -> m (ConnectionConfig s) -connectWithTLS' = connectInternal ircTLSClient defaultOnConnect defaultOnDisconnect +connectWithTLS' lg host port = + connectInternal (C.ircTLSClient port host) defaultOnConnect defaultOnDisconnect lg host port +-- | Connect to a server with TLS using the given TLS config, with the +-- provided logging function. +connectWithTLSConfig' :: MonadIO m + => (Origin -> ByteString -> IO ()) + -- ^ The message logger + -> TLS.TLSClientConfig + -- ^ The TLS config + -> NominalDiffTime + -- ^ The flood cooldown + -> m (ConnectionConfig s) +connectWithTLSConfig' lg cfg = + connectInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect lg host port + where + host = TLS.tlsClientHost cfg + port = TLS.tlsClientPort cfg + +-- | Connect to a server with TLS using the given certificate +-- verifier, with the provided logging function. +connectWithTLSVerify' :: MonadIO m + => (Origin -> ByteString -> IO ()) + -- ^ The message logger + -> (X.CertificateStore -> TLS.ValidationCache -> X.ServiceID -> X.CertificateChain -> IO [X.FailedReason]) + -- ^ The certificate verifier. Returns an empty list if the cert is + -- good. + -> ByteString + -- ^ The hostname + -> Int + -- ^ The port + -> NominalDiffTime + -- ^ The flood cooldown + -> m (ConnectionConfig s) +connectWithTLSVerify' lg verifier host port = + connectInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect lg host port + where + cfg = + let cfg0 = C.defaultTLSConfig port host + -- this is a partial pattern match, but because I'm the + -- author of irc-conduit I can do this. + TLS.TLSSettings cTLSSettings = TLS.tlsClientTLSSettings cfg0 + cHooks = TLS.clientHooks cTLSSettings + in cfg0 { TLS.tlsClientTLSSettings = TLS.TLSSettings cTLSSettings + { TLS.clientHooks = cHooks + { TLS.onServerCertificate = verifier } + } + } + -- * Starting -- | Run the event loop for a server, receiving messages and handing @@ -136,7 +226,7 @@ , _realname = n , _password = Nothing , _channels = [] - , _ctcpVer = "irc-client-0.4.3" + , _ctcpVer = "irc-client-0.4.4" , _eventHandlers = defaultEventHandlers , _ignore = [] } diff --git a/Network/IRC/Client/Handlers.hs b/Network/IRC/Client/Handlers.hs --- a/Network/IRC/Client/Handlers.hs +++ b/Network/IRC/Client/Handlers.hs @@ -1,8 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} --- | The default event handlers. Handlers are invoked concurrently --- when matching events are received from the server. +-- | +-- Module : Network.IRC.Client.Handlers +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, OverloadedStrings +-- +-- The default event handlers. Handlers are invoked concurrently when +-- matching events are received from the server. module Network.IRC.Client.Handlers ( -- * Event handlers defaultEventHandlers diff --git a/Network/IRC/Client/Internal.hs b/Network/IRC/Client/Internal.hs --- a/Network/IRC/Client/Internal.hs +++ b/Network/IRC/Client/Internal.hs @@ -3,14 +3,25 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Most of the hairy code. This isn't all internal, due to messy +-- | +-- Module : Network.IRC.Client.Internal +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, OverloadedStrings, RankNTypes, ScopedTypeVariables +-- +-- Most of the hairy code. This isn't all internal, due to messy -- dependencies, but I've tried to make this as \"internal\" as -- reasonably possible. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. module Network.IRC.Client.Internal where import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) -import Control.Concurrent.STM (atomically, readTVar, retry, writeTVar) +import Control.Concurrent.STM (atomically, readTVar, writeTVar) import Control.Exception (SomeException, catch, throwIO) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -34,7 +45,7 @@ -- | Connect to a server using the supplied connection function. connectInternal :: MonadIO m - => (Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ()) + => (IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ()) -- ^ Function to start the network conduits. -> StatefulIRC s () -- ^ Connect handler @@ -45,7 +56,7 @@ -> ByteString -- ^ Server hostname -> Int - -- ^ Server post + -- ^ Server port -> NominalDiffTime -- ^ Flood timeout -> m (ConnectionConfig s) @@ -85,12 +96,10 @@ -- Run the event loop, and call the disconnect handler if the remote -- end closes the socket. cconf <- connectionConfig - let flood = _flood cconf - let func = _func cconf - let logf = _logfunc cconf - let port = _port cconf - let queue = _sendqueue cconf - let server = _server cconf + let flood = _flood cconf + let func = _func cconf + let logf = _logfunc cconf + let queue = _sendqueue cconf antiflood <- liftIO $ floodProtector flood @@ -100,7 +109,7 @@ let sink = forgetful =$= logConduit (logf FromServer . _raw) =$ eventSink state (exc :: Maybe SomeException) <- liftIO $ catch - (func port server initialise sink source >> pure Nothing) + (func initialise sink source >> pure Nothing) (pure . Just) disconnect diff --git a/Network/IRC/Client/Types.hs b/Network/IRC/Client/Types.hs --- a/Network/IRC/Client/Types.hs +++ b/Network/IRC/Client/Types.hs @@ -1,6 +1,14 @@ {-# LANGUAGE RankNTypes #-} --- | Types for IRC clients. See also +-- | +-- Module : Network.IRC.Client.Types +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : RankNTypes +--- +-- Types for IRC clients. See also -- and -- . module Network.IRC.Client.Types @@ -124,7 +132,7 @@ -- | The static state of an IRC server connection. data ConnectionConfig s = ConnectionConfig - { _func :: Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO () + { _func :: IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO () -- ^ Function to connect and start the conduits. , _sendqueue :: TBMChan IrcMessage -- ^ Message send queue. diff --git a/Network/IRC/Client/Utils.hs b/Network/IRC/Client/Utils.hs --- a/Network/IRC/Client/Utils.hs +++ b/Network/IRC/Client/Utils.hs @@ -1,4 +1,12 @@ --- |Commonly-used utility functions for IRC clients. +-- | +-- Module : Network.IRC.Client.Utils +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : portable +-- +-- Commonly-used utility functions for IRC clients. module Network.IRC.Client.Utils where import Control.Concurrent.STM (TVar, STM, atomically, readTVar, writeTVar) diff --git a/irc-client.cabal b/irc-client.cabal --- a/irc-client.cabal +++ b/irc-client.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.3.0 +version: 0.4.4.0 -- A short (one-line) description of the package. synopsis: An IRC client library. @@ -71,9 +71,10 @@ , Network.IRC.Client.Handlers , Network.IRC.Client.Types , Network.IRC.Client.Utils + , Network.IRC.Client.Internal -- Modules included in this library but not exported. - other-modules: Network.IRC.Client.Internal + -- other-modules: -- Compile with -Wall by default ghc-options: -Wall @@ -82,17 +83,23 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.7 && <5 - , bytestring >=0.10 && <0.11 - , conduit >=1.2 && <1.3 - , irc-conduit >=0.1.1 && <0.3 - , irc-ctcp >=0.1.2 && <0.2 - , old-locale >=1.0 && <1.1 - , stm >=2.4 && <2.5 - , stm-conduit >=2.5 && <3.1 - , text >=1.1 && <1.3 - , time >=1.4 && <1.7 - , transformers >=0.3 && <0.6 + build-depends: base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , conduit >=1.2 && <1.3 + , connection >=0.2 && <0.3 + , irc-conduit >=0.2.1 && <0.3 + , irc-ctcp >=0.1.2 && <0.2 + , network-conduit-tls >=1.1 && <1.3 + , old-locale >=1.0 && <1.1 + , stm >=2.4 && <2.5 + , stm-conduit >=2.5 && <3.1 + , text >=1.1 && <1.3 + , time >=1.4 && <1.7 + , tls >=1.3 && <1.4 + , transformers >=0.3 && <0.6 + , x509 >=1.6 && <1.7 + , x509-store >=1.6 && <1.7 + , x509-validation >=1.6 && <1.7 -- Directories containing source files. -- hs-source-dirs: @@ -107,4 +114,4 @@ source-repository this type: git location: https://github.com/barrucadu/irc-client.git - tag: 0.4.3.0 + tag: 0.4.4.0