{-# 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, 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)
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)
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
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)
floodProtector :: MonadIO m
=> NominalDiffTime
-> 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
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
UTCTime
now' <- IO UTCTime
getCurrentTime
forall a. MVar a -> a -> IO ()
putMVar MVar UTCTime
mvar UTCTime
now'
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
val
ircClient :: Int
-> ByteString
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> 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
ircWithConn :: ((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 ()
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
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)
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)
defaultTLSConfig :: Int
-> ByteString
-> 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
""
validate :: OnServerCertificate
validate CertificateStore
cs ValidationCache
vc ServiceID
sid CertificateChain
cc = do
[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
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