{-# 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 :: forall (m :: * -> *).
Monad m =>
ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder = forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
chunked forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield 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 :: forall (m :: * -> *). Monad m => ConduitM ByteString IrcEvent m ()
ircLossyDecoder = forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
chunked forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall {m :: * -> *} {i}.
Monad m =>
ByteString -> ConduitT i IrcEvent m ()
lossy
  where
    lossy :: ByteString -> ConduitT i IrcEvent m ()
lossy ByteString
bs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ByteString
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield 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 :: forall (m :: * -> *).
Monad m =>
ConduitM IrcMessage ByteString m ()
ircEncoder = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>ByteString
"\r\n") 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 :: forall (m :: * -> *) a.
MonadIO m =>
NominalDiffTime -> IO (ConduitM a a m ())
floodProtector NominalDiffTime
delay = do
  UTCTime
now  <- IO UTCTime
getCurrentTime
  MVar UTCTime
mvar <- forall a. a -> IO (MVar a)
newMVar UTCTime
now

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ \o
val -> do
      -- Block until the delay has passed
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        UTCTime
lastT <- 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

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

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

      -- Send the value downstream
      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 forall a b. (a -> b) -> a -> b
$ forall a. ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient 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 forall a b. (a -> b) -> a -> b
$ \AppData
appdata -> forall a. Concurrently a -> IO a
runConcurrently forall a b. (a -> b) -> a -> b
$
     forall a. IO a -> Concurrently a
Concurrently IO ()
start
  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. IO a -> Concurrently a
Concurrently (forall {ad} {b}. HasReadWrite ad => ad -> IO b
runSource AppData
appdata)
  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. IO a -> Concurrently a
Concurrently (forall {ad}. HasReadWrite ad => ad -> IO ()
runSink   AppData
appdata)

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

    runSink :: ad -> IO ()
runSink ad
appdata =
      forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () IrcMessage IO ()
prod forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
Monad m =>
ConduitM IrcMessage ByteString m ()
ircEncoder forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 (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 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 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
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FailedReason
UnknownCA, FailedReason
SelfSigned]) [FailedReason]
res