{-# 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 :: ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder = ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
chunked ConduitM ByteString ByteString m ()
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ByteString
-> ConduitM ByteString (Either ByteString IrcEvent) m ())
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (Either ByteString IrcEvent
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Either ByteString IrcEvent
-> ConduitM ByteString (Either ByteString IrcEvent) m ())
-> (ByteString -> Either ByteString IrcEvent)
-> ByteString
-> ConduitM ByteString (Either ByteString IrcEvent) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString IrcEvent
fromByteString)
ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m ()
ircLossyDecoder :: ConduitM ByteString IrcEvent m ()
ircLossyDecoder = ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
chunked ConduitM ByteString ByteString m ()
-> ConduitM ByteString IrcEvent m ()
-> ConduitM ByteString IrcEvent m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ByteString -> ConduitM ByteString IrcEvent m ())
-> ConduitM ByteString IrcEvent m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ByteString -> ConduitM ByteString IrcEvent m ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i IrcEvent m ()
lossy
where
lossy :: ByteString -> ConduitT i IrcEvent m ()
lossy ByteString
bs = (ByteString -> ConduitT i IrcEvent m ())
-> (IrcEvent -> ConduitT i IrcEvent m ())
-> Either ByteString IrcEvent
-> ConduitT i IrcEvent m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ByteString
_ -> () -> ConduitT i IrcEvent m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IrcEvent -> ConduitT i IrcEvent m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Either ByteString IrcEvent -> ConduitT i IrcEvent m ())
-> Either ByteString IrcEvent -> ConduitT i IrcEvent m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString IrcEvent
fromByteString ByteString
bs
ircEncoder :: Monad m => ConduitM IrcMessage ByteString m ()
ircEncoder :: ConduitM IrcMessage ByteString m ()
ircEncoder = (IrcMessage -> ConduitM IrcMessage ByteString m ())
-> ConduitM IrcMessage ByteString m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (ByteString -> ConduitM IrcMessage ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ByteString -> ConduitM IrcMessage ByteString m ())
-> (IrcMessage -> ByteString)
-> IrcMessage
-> ConduitM IrcMessage ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>ByteString
"\r\n") (ByteString -> ByteString)
-> (IrcMessage -> ByteString) -> IrcMessage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IrcMessage -> ByteString
toByteString)
floodProtector :: MonadIO m
=> NominalDiffTime
-> IO (ConduitM a a m ())
floodProtector :: NominalDiffTime -> IO (ConduitM a a m ())
floodProtector NominalDiffTime
delay = do
UTCTime
now <- IO UTCTime
getCurrentTime
MVar UTCTime
mvar <- UTCTime -> IO (MVar UTCTime)
forall a. a -> IO (MVar a)
newMVar UTCTime
now
ConduitM a a m () -> IO (ConduitM a a m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ConduitM a a m () -> IO (ConduitM a a m ()))
-> ConduitM a a m () -> IO (ConduitM a a m ())
forall a b. (a -> b) -> a -> b
$ MVar UTCTime -> ConduitM a a m ()
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 = (o -> ConduitT o o m ()) -> ConduitT o o m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((o -> ConduitT o o m ()) -> ConduitT o o m ())
-> (o -> ConduitT o o m ()) -> ConduitT o o m ()
forall a b. (a -> b) -> a -> b
$ \o
val -> do
IO () -> ConduitT o o m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT o o m ()) -> IO () -> ConduitT o o m ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
lastT <- MVar UTCTime -> IO UTCTime
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
next) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Int -> IO ()
threadDelay (Int -> IO ())
-> (NominalDiffTime -> Int) -> NominalDiffTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime -> IO ()) -> NominalDiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1000000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
next UTCTime
now
UTCTime
now' <- IO UTCTime
getCurrentTime
MVar UTCTime -> UTCTime -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar UTCTime
mvar UTCTime
now'
o -> ConduitT o o m ()
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 (((AppData -> IO ()) -> IO ())
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ())
-> ((AppData -> IO ()) -> IO ())
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient (ClientSettings -> (AppData -> IO ()) -> IO ())
-> ClientSettings -> (AppData -> IO ()) -> IO ()
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 ((AppData -> IO ()) -> IO ()) -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppData
appdata -> Concurrently () -> IO ()
forall a. Concurrently a -> IO a
runConcurrently (Concurrently () -> IO ()) -> Concurrently () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently IO ()
start
Concurrently () -> Concurrently Any -> Concurrently Any
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO Any -> Concurrently Any
forall a. IO a -> Concurrently a
Concurrently (AppData -> IO Any
forall ad b. HasReadWrite ad => ad -> IO b
runSource AppData
appdata)
Concurrently Any -> Concurrently () -> Concurrently ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> Concurrently ()
forall a. IO a -> Concurrently a
Concurrently (AppData -> IO ()
forall ad. HasReadWrite ad => ad -> IO ()
runSink AppData
appdata)
where
runSource :: ad -> IO b
runSource ad
appdata = do
ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ad -> ConduitT () ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource ad
appdata ConduitT () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString (Either ByteString IrcEvent) IO ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder ConduitM ByteString (Either ByteString IrcEvent) IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM ByteString Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (Either ByteString IrcEvent) Void IO ()
cons
IOError -> IO b
forall a. IOError -> IO a
ioError (IOError -> IO b) -> IOError -> IO b
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Upstream source closed."
runSink :: ad -> IO ()
runSink ad
appdata =
ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitM () IrcMessage IO ()
prod ConduitM () IrcMessage IO ()
-> ConduitM IrcMessage Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM IrcMessage ByteString IO ()
forall (m :: * -> *).
Monad m =>
ConduitM IrcMessage ByteString m ()
ircEncoder ConduitM IrcMessage ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitM IrcMessage Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ad -> ConduitM ByteString Void IO ()
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 (TLSClientConfig -> (AppData -> IO ()) -> IO ()
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 (Text -> String) -> Text -> String
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 (ClientHooks -> OnServerCertificate)
-> ClientHooks -> OnServerCertificate
forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cpara) CertificateStore
cs ValidationCache
vc ServiceID
sid CertificateChain
cc
[FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FailedReason] -> IO [FailedReason])
-> [FailedReason] -> IO [FailedReason]
forall a b. (a -> b) -> a -> b
$ (FailedReason -> Bool) -> [FailedReason] -> [FailedReason]
forall a. (a -> Bool) -> [a] -> [a]
filter (FailedReason -> [FailedReason] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FailedReason
UnknownCA, FailedReason
SelfSigned]) [FailedReason]
res