{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Network.IRC.Conduit
(
ChannelName
, NickName
, ServerName
, Reason
, IsModeSet
, ModeFlag
, ModeArg
, NumericArg
, Target
, IrcEvent
, IrcSource
, IrcMessage
, Event(..)
, Source(..)
, Message(..)
, ircDecoder
, ircLossyDecoder
, ircEncoder
, floodProtector
, ircClient
, ircWithConn
, ircTLSClient
, ircTLSClient'
, defaultTLSConfig
, rawMessage
, toByteString
, module Network.IRC.Conduit.Lens
) where
import Control.Applicative ((*>))
import Control.Concurrent (newMVar, takeMVar, putMVar, 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, yield, runConduit)
import Data.Conduit.Network (AppData, clientSettings, runTCPClient, appSource, appSink)
import Data.Conduit.Network.TLS (TLSClientConfig(..), tlsClientConfig, runTLSClient)
import Data.Monoid ((<>))
import Data.Text (unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (NominalDiffTime, getCurrentTime, addUTCTime, diffUTCTime)
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 (ClientParams(..), ClientHooks(..), Supported(..), Version(..), defaultParamsClient)
import Network.TLS.Extra (ciphersuite_strong)
ircDecoder :: Monad m => ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder = chunked .| awaitForever (yield . fromByteString)
ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m ()
ircLossyDecoder = chunked .| awaitForever lossy
where
lossy bs = either (\_ -> return ()) yield $ fromByteString bs
ircEncoder :: Monad m => ConduitM IrcMessage ByteString m ()
ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString)
floodProtector :: MonadIO m
=> NominalDiffTime
-> IO (ConduitM a a m ())
floodProtector delay = do
now <- getCurrentTime
mvar <- newMVar now
return $ conduit mvar
where
conduit mvar = awaitForever $ \val -> do
liftIO $ do
lastT <- takeMVar mvar
now <- getCurrentTime
let next = addUTCTime delay lastT
when (now < next) $
threadDelay . ceiling $ 1000000 * diffUTCTime next now
now' <- getCurrentTime
putMVar mvar now'
yield val
ircClient :: Int
-> ByteString
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host
ircWithConn :: ((AppData -> IO ()) -> IO ())
-> 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
ircTLSClient :: Int
-> ByteString
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host)
ircTLSClient' :: TLSClientConfig
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient' cfg = ircWithConn (runTLSClient cfg)
defaultTLSConfig :: Int
-> ByteString
-> 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) ""
validate cs vc sid cc = do
res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
return $ filter (`notElem` [UnknownCA, SelfSigned]) res