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
) 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 (Conduit, Consumer, Producer, (=$), ($$), (=$=), awaitForever, yield)
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.X509.Validation (FailedReason(..))
import Network.Connection (TLSSettings(..))
import Network.IRC.Conduit.Internal
import Network.TLS (ClientParams(..), ClientHooks(..), Supported(..), Version(..), defaultParamsClient)
import Network.TLS.Extra (ciphersuite_all)
ircDecoder :: Monad m => Conduit ByteString m (Either ByteString IrcEvent)
ircDecoder = chunked =$= awaitForever (yield . fromByteString)
ircLossyDecoder :: Monad m => Conduit ByteString m IrcEvent
ircLossyDecoder = chunked =$= awaitForever lossy
where
lossy bs = either (\_ -> return ()) yield $ fromByteString bs
ircEncoder :: Monad m => Conduit IrcMessage m ByteString
ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString)
floodProtector :: MonadIO m
=> NominalDiffTime
-> IO (Conduit a m a)
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 ()
-> Consumer (Either ByteString IrcEvent) IO ()
-> Producer IO IrcMessage
-> IO ()
ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host
ircWithConn :: ((AppData -> IO ()) -> IO ())
-> IO ()
-> Consumer (Either ByteString IrcEvent) IO ()
-> Producer IO IrcMessage
-> IO ()
ircWithConn runner start cons prod = runner $ \appdata -> runConcurrently $
Concurrently start
*> Concurrently (appSource appdata =$= exceptionalConduit $$ ircDecoder =$ cons)
*> Concurrently (prod $$ ircEncoder =$ appSink appdata)
ircTLSClient :: Int
-> ByteString
-> IO ()
-> Consumer (Either ByteString IrcEvent) IO ()
-> Producer IO IrcMessage -> IO ()
ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host)
ircTLSClient' :: TLSClientConfig
-> IO ()
-> Consumer (Either ByteString IrcEvent) IO ()
-> Producer IO IrcMessage -> 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_all
}
}
}
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