module Network.IRC.Conduit
(
ChannelName
, NickName
, ServerName
, Reason
, IsModeSet
, ModeFlag
, ModeArg
, NumericArg
, Target
, IrcEvent
, IrcSource
, IrcMessage
, Event(..)
, Source(..)
, Message(..)
, ircDecoder
, ircLossyDecoder
, ircEncoder
, floodProtector
, ircClient
, ircTLSClient
, ircWithConn
, rawMessage
, toByteString
) where
import Control.Applicative ((*>))
import Control.Concurrent (newMVar, takeMVar, putMVar, threadDelay)
import Control.Concurrent.Async (Concurrently(..))
import Control.Exception (catch)
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(..), TLSException, Version(..), defaultParamsClient)
import Network.TLS.Extra (ciphersuite_all)
import System.IO.Error (catchIOError)
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 (next < now) $
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
ircTLSClient :: Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ()
ircTLSClient port host = ircWithConn . runTLSClient . mangle $ tlsClientConfig port host
where
mangle tlsSettings = tlsSettings
{ 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 (/=SelfSigned) res
ircWithConn :: ((AppData -> IO ()) -> IO ())
-> IO ()
-> Consumer (Either ByteString IrcEvent) IO ()
-> Producer IO IrcMessage
-> IO ()
ircWithConn runner start cons prod = (go `catch` raiseTLS) `catchIOError` ignore
where
go = runner $ \appdata ->
runConcurrently $
Concurrently start *>
Concurrently (appSource appdata =$= exceptionalConduit $$ ircDecoder =$ cons) *>
Concurrently (prod $$ ircEncoder =$ appSink appdata)
ignore _ = return ()
raiseTLS = const . ioError $ userError "TLS exception" :: TLSException -> IO ()