{-# 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 :: ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder = ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
chunked ConduitM ByteString ByteString m ()
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ByteString
 -> ConduitM ByteString (Either ByteString IrcEvent) m ())
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (Either ByteString IrcEvent
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Either ByteString IrcEvent
 -> ConduitM ByteString (Either ByteString IrcEvent) m ())
-> (ByteString -> Either ByteString IrcEvent)
-> ByteString
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString IrcEvent
fromByteString)

-- |Like 'ircDecoder', but discards messages which could not be
-- decoded.
ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m ()
ircLossyDecoder :: ConduitM ByteString IrcEvent m ()
ircLossyDecoder = ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
chunked ConduitM ByteString ByteString m ()
-> ConduitM ByteString IrcEvent m ()
-> ConduitM ByteString IrcEvent m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ByteString -> ConduitM ByteString IrcEvent m ())
-> ConduitM ByteString IrcEvent m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ByteString -> ConduitM ByteString IrcEvent m ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i IrcEvent m ()
lossy
  where
    lossy :: ByteString -> ConduitT i IrcEvent m ()
lossy ByteString
bs = (ByteString -> ConduitT i IrcEvent m ())
-> (IrcEvent -> ConduitT i IrcEvent m ())
-> Either ByteString IrcEvent
-> ConduitT i IrcEvent m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ByteString
_ -> () -> ConduitT i IrcEvent m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IrcEvent -> ConduitT i IrcEvent m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Either ByteString IrcEvent -> ConduitT i IrcEvent m ())
-> Either ByteString IrcEvent -> ConduitT i IrcEvent m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString IrcEvent
fromByteString ByteString
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 :: ConduitM IrcMessage ByteString m ()
ircEncoder = (IrcMessage -> ConduitM IrcMessage ByteString m ())
-> ConduitM IrcMessage ByteString m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (ByteString -> ConduitM IrcMessage ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ByteString -> ConduitM IrcMessage ByteString m ())
-> (IrcMessage -> ByteString)
-> IrcMessage
-> ConduitM IrcMessage ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>ByteString
"\r\n") (ByteString -> ByteString)
-> (IrcMessage -> ByteString) -> IrcMessage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IrcMessage -> ByteString
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 :: NominalDiffTime -> IO (ConduitM a a m ())
floodProtector NominalDiffTime
delay = do
  UTCTime
now  <- IO UTCTime
getCurrentTime
  MVar UTCTime
mvar <- UTCTime -> IO (MVar UTCTime)
forall a. a -> IO (MVar a)
newMVar UTCTime
now

  ConduitM a a m () -> IO (ConduitM a a m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ConduitM a a m () -> IO (ConduitM a a m ()))
-> ConduitM a a m () -> IO (ConduitM a a m ())
forall a b. (a -> b) -> a -> b
$ MVar UTCTime -> ConduitM a a m ()
forall (m :: * -> *) o.
MonadIO m =>
MVar UTCTime -> ConduitT o o m ()
conduit MVar UTCTime
mvar

  where
    conduit :: MVar UTCTime -> ConduitT o o m ()
conduit MVar UTCTime
mvar = (o -> ConduitT o o m ()) -> ConduitT o o m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((o -> ConduitT o o m ()) -> ConduitT o o m ())
-> (o -> ConduitT o o m ()) -> ConduitT o o m ()
forall a b. (a -> b) -> a -> b
$ \o
val -> do
      -- Block until the delay has passed
      IO () -> ConduitT o o m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT o o m ()) -> IO () -> ConduitT o o m ()
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
lastT <- MVar UTCTime -> IO UTCTime
forall a. MVar a -> IO a
takeMVar MVar UTCTime
mvar
        UTCTime
now   <- IO UTCTime
getCurrentTime

        let next :: UTCTime
next = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
delay UTCTime
lastT

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
next) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Int -> IO ()
threadDelay (Int -> IO ())
-> (NominalDiffTime -> Int) -> NominalDiffTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime -> IO ()) -> NominalDiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1000000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
next UTCTime
now

      -- Update the time
        UTCTime
now' <- IO UTCTime
getCurrentTime
        MVar UTCTime -> UTCTime -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar UTCTime
mvar UTCTime
now'

      -- Send the value downstream
      o -> ConduitT o o m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
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 :: Int
-> ByteString
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircClient Int
port ByteString
host = ((AppData -> IO ()) -> IO ())
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircWithConn (((AppData -> IO ()) -> IO ())
 -> IO ()
 -> ConduitM (Either ByteString IrcEvent) Void IO ()
 -> ConduitM () IrcMessage IO ()
 -> IO ())
-> ((AppData -> IO ()) -> IO ())
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient (ClientSettings -> (AppData -> IO ()) -> IO ())
-> ClientSettings -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ClientSettings
clientSettings Int
port ByteString
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 :: ((AppData -> IO ()) -> IO ())
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircWithConn (AppData -> IO ()) -> IO ()
runner IO ()
start ConduitM (Either ByteString IrcEvent) Void IO ()
cons ConduitM () IrcMessage IO ()
prod = (AppData -> IO ()) -> IO ()
runner ((AppData -> IO ()) -> IO ()) -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppData
appdata -> Concurrently () -> IO ()
forall a. Concurrently a -> IO a
runConcurrently (Concurrently () -> IO ()) -> Concurrently () -> IO ()
forall a b. (a -> b) -> a -> b
$
     IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently IO ()
start
  Concurrently () -> Concurrently Any -> Concurrently Any
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO Any -> Concurrently Any
forall a. IO a -> Concurrently a
Concurrently (AppData -> IO Any
forall ad b. HasReadWrite ad => ad -> IO b
runSource AppData
appdata)
  Concurrently Any -> Concurrently () -> Concurrently ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (AppData -> IO ()
forall ad. HasReadWrite ad => ad -> IO ()
runSink   AppData
appdata)

  where
    runSource :: ad -> IO b
runSource ad
appdata  = do
      ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ad -> ConduitT () ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource ad
appdata ConduitT () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString (Either ByteString IrcEvent) IO ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder ConduitM ByteString (Either ByteString IrcEvent) IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM ByteString Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (Either ByteString IrcEvent) Void IO ()
cons
      IOError -> IO b
forall a. IOError -> IO a
ioError    (IOError -> IO b) -> IOError -> IO b
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Upstream source closed."

    runSink :: ad -> IO ()
runSink ad
appdata =
      ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitM () IrcMessage IO ()
prod ConduitM () IrcMessage IO ()
-> ConduitM IrcMessage Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM IrcMessage ByteString IO ()
forall (m :: * -> *).
Monad m =>
ConduitM IrcMessage ByteString m ()
ircEncoder ConduitM IrcMessage ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitM IrcMessage Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ad -> ConduitM ByteString Void IO ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
appSink ad
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 :: Int
-> ByteString
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient Int
port ByteString
host = TLSClientConfig
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient' (Int -> ByteString -> TLSClientConfig
defaultTLSConfig Int
port ByteString
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' :: TLSClientConfig
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient' TLSClientConfig
cfg = ((AppData -> IO ()) -> IO ())
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircWithConn (TLSClientConfig -> (AppData -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
TLSClientConfig -> (AppData -> m a) -> m a
runTLSClient TLSClientConfig
cfg)

-- |The default TLS settings for 'ircTLSClient'.
defaultTLSConfig :: Int
                 -- ^The port number
                 -> ByteString
                 -- ^ The hostname
                 -> TLSClientConfig
defaultTLSConfig :: Int -> ByteString -> TLSClientConfig
defaultTLSConfig Int
port ByteString
host = (Int -> ByteString -> TLSClientConfig
tlsClientConfig Int
port ByteString
host)
  { tlsClientTLSSettings :: TLSSettings
tlsClientTLSSettings = ClientParams -> TLSSettings
TLSSettings ClientParams
cpara
    { clientHooks :: ClientHooks
clientHooks = (ClientParams -> ClientHooks
clientHooks ClientParams
cpara)
      { onServerCertificate :: OnServerCertificate
onServerCertificate = OnServerCertificate
validate }
    , clientSupported :: Supported
clientSupported = (ClientParams -> Supported
clientSupported ClientParams
cpara)
      { supportedVersions :: [Version]
supportedVersions = [Version
TLS12, Version
TLS11, Version
TLS10]
      , supportedCiphers :: [Cipher]
supportedCiphers = [Cipher]
ciphersuite_strong
      }
    }
  }

  where
    cpara :: ClientParams
cpara = String -> ByteString -> ClientParams
defaultParamsClient (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
host) ByteString
""

    -- Make the TLS certificate validation a bit more generous. In
    -- particular, allow self-signed certificates.
    validate :: OnServerCertificate
validate CertificateStore
cs ValidationCache
vc ServiceID
sid CertificateChain
cc = do
      -- First validate with the standard function
      [FailedReason]
res <- (ClientHooks -> OnServerCertificate
onServerCertificate (ClientHooks -> OnServerCertificate)
-> ClientHooks -> OnServerCertificate
forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cpara) CertificateStore
cs ValidationCache
vc ServiceID
sid CertificateChain
cc
      -- Then strip out non-issues
      [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FailedReason] -> IO [FailedReason])
-> [FailedReason] -> IO [FailedReason]
forall a b. (a -> b) -> a -> b
$ (FailedReason -> Bool) -> [FailedReason] -> [FailedReason]
forall a. (a -> Bool) -> [a] -> [a]
filter (FailedReason -> [FailedReason] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FailedReason
UnknownCA, FailedReason
SelfSigned]) [FailedReason]
res