diff options
Diffstat (limited to 'deps/irc-conduit/Network/IRC/Conduit.hs')
| -rw-r--r-- | deps/irc-conduit/Network/IRC/Conduit.hs | 230 |
1 files changed, 230 insertions, 0 deletions
diff --git a/deps/irc-conduit/Network/IRC/Conduit.hs b/deps/irc-conduit/Network/IRC/Conduit.hs new file mode 100644 index 0000000..1185749 --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : OverloadedStrings, RankNTypes +-- +-- Conduits for serialising and deserialising IRC messages. +-- +-- The 'Event', 'Message', and 'Source' types are parameterised on the +-- underlying representation, and are functors. Decoding and encoding +-- only work in terms of 'ByteString's, but the generality is provided +-- so that programs using this library can operate in terms of 'Text', +-- or some other more useful representation, with great ease. +module Network.IRC.Conduit + ( -- *Type synonyms + ChannelName + , NickName + , ServerName + , Reason + , IsModeSet + , ModeFlag + , ModeArg + , NumericArg + , Target + , IrcEvent + , IrcSource + , IrcMessage + + -- *Messages + , Event(..) + , Source(..) + , Message(..) + + -- *Conduits + , ircDecoder + , ircLossyDecoder + , ircEncoder + , floodProtector + + -- *Networking + , ircClient + , ircWithConn + -- ** TLS + , ircTLSClient + , ircTLSClient' + , defaultTLSConfig + + -- *Utilities + , rawMessage + , toByteString + + -- *Lenses + , module Network.IRC.Conduit.Lens + ) where + +import Control.Applicative ((*>)) +import Control.Concurrent (newMVar, putMVar, takeMVar, + threadDelay) +import Control.Concurrent.Async (Concurrently(..)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.Conduit (ConduitM, awaitForever, + runConduit, yield, (.|)) +import Data.Conduit.Network (AppData, appSink, appSource, + clientSettings, runTCPClient) +import Data.Conduit.Network.TLS (TLSClientConfig(..), + runTLSClient, tlsClientConfig) +import Data.Monoid ((<>)) +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock (NominalDiffTime, addUTCTime, + diffUTCTime, getCurrentTime) +import Data.Void (Void) +import Data.X509.Validation (FailedReason(..)) +import Network.Connection (TLSSettings(..)) +import Network.IRC.Conduit.Internal +import Network.IRC.Conduit.Lens +import Network.TLS (ClientHooks(..), + ClientParams(..), Supported(..), + Version(..), defaultParamsClient) +import Network.TLS.Extra (ciphersuite_strong) + +-- *Conduits + +-- |A conduit which takes as input bytestrings representing encoded +-- IRC messages, and decodes them to events. If decoding fails, the +-- original bytestring is just passed through. +ircDecoder :: Monad m => ConduitM ByteString (Either ByteString IrcEvent) m () +ircDecoder = chunked .| awaitForever (yield . fromByteString) + +-- |Like 'ircDecoder', but discards messages which could not be +-- decoded. +ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m () +ircLossyDecoder = chunked .| awaitForever lossy + where + lossy bs = either (\_ -> return ()) yield $ fromByteString bs + +-- |A conduit which takes as input irc messages, and produces as +-- output the encoded bytestring representation. +ircEncoder :: Monad m => ConduitM IrcMessage ByteString m () +ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString) + +-- |A conduit which rate limits output sent downstream. Awaiting on +-- this conduit will block, even if there is output ready, until the +-- time limit has passed. +floodProtector :: MonadIO m + => NominalDiffTime + -- ^The minimum time between sending adjacent messages. + -> IO (ConduitM a a m ()) +floodProtector delay = do + now <- getCurrentTime + mvar <- newMVar now + + return $ conduit mvar + + where + conduit mvar = awaitForever $ \val -> do + -- Block until the delay has passed + liftIO $ do + lastT <- takeMVar mvar + now <- getCurrentTime + + let next = addUTCTime delay lastT + + when (now < next) $ + threadDelay . ceiling $ 1000000 * diffUTCTime next now + + -- Update the time + now' <- getCurrentTime + putMVar mvar now' + + -- Send the value downstream + yield val + +-- *Networking + +-- |Connect to a network server, without TLS, and concurrently run the +-- producer and consumer. +ircClient :: Int + -- ^The port number + -> ByteString + -- ^The hostname + -> IO () + -- ^Any initialisation work (started concurrently with the + -- producer and consumer) + -> ConduitM (Either ByteString IrcEvent) Void IO () + -- ^The consumer of irc events + -> ConduitM () IrcMessage IO () + -- ^The producer of irc messages + -> IO () +ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host + +-- |Run the IRC conduits using a provided connection. +-- +-- Starts the connection and concurrently run the initialiser, event +-- consumer, and message sources. Terminates as soon as one throws an +-- exception. +ircWithConn :: ((AppData -> IO ()) -> IO ()) + -- ^The initialised connection. + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircWithConn runner start cons prod = runner $ \appdata -> runConcurrently $ + Concurrently start + *> Concurrently (runSource appdata) + *> Concurrently (runSink appdata) + + where + runSource appdata = do + runConduit $ appSource appdata .| ircDecoder .| cons + ioError $ userError "Upstream source closed." + + runSink appdata = + runConduit $ prod .| ircEncoder .| appSink appdata + +-- **TLS + +-- |Like 'ircClient', but with TLS. The TLS configuration used is +-- 'defaultTLSConfig'. +ircTLSClient :: Int + -> ByteString + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host) + +-- |Like 'ircTLSClient', but takes the configuration to use, which +-- includes the host and port. +ircTLSClient' :: TLSClientConfig + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircTLSClient' cfg = ircWithConn (runTLSClient cfg) + +-- |The default TLS settings for 'ircTLSClient'. +defaultTLSConfig :: Int + -- ^The port number + -> ByteString + -- ^ The hostname + -> TLSClientConfig +defaultTLSConfig port host = (tlsClientConfig port host) + { tlsClientTLSSettings = TLSSettings cpara + { clientHooks = (clientHooks cpara) + { onServerCertificate = validate } + , clientSupported = (clientSupported cpara) + { supportedVersions = [TLS12, TLS11, TLS10] + , supportedCiphers = ciphersuite_strong + } + } + } + + where + cpara = defaultParamsClient (unpack $ decodeUtf8 host) "" + + -- Make the TLS certificate validation a bit more generous. In + -- particular, allow self-signed certificates. + validate cs vc sid cc = do + -- First validate with the standard function + res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc + -- Then strip out non-issues + return $ filter (`notElem` [UnknownCA, SelfSigned]) res |