Initial commit

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