1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-- |
-- Module : Network.IRC.Conduit
-- Copyright : (c) 2016 Michael Walker
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : OverloadedStrings, RankNTypes
--
-- Conduits for serialising and deserialising IRC messages.
--
-- The 'Event', 'Message', and 'Source' types are parameterised on the
-- underlying representation, and are functors. Decoding and encoding
-- only work in terms of 'ByteString's, but the generality is provided
-- so that programs using this library can operate in terms of 'Text',
-- or some other more useful representation, with great ease.
module Network.IRC.Conduit
( -- *Type synonyms
ChannelName
, NickName
, ServerName
, Reason
, IsModeSet
, ModeFlag
, ModeArg
, NumericArg
, Target
, IrcEvent
, IrcSource
, IrcMessage
-- *Messages
, Event(..)
, Source(..)
, Message(..)
-- *Conduits
, ircDecoder
, ircLossyDecoder
, ircEncoder
, floodProtector
-- *Networking
, ircClient
, ircWithConn
-- ** TLS
, ircTLSClient
, ircTLSClient'
, defaultTLSConfig
-- *Utilities
, rawMessage
, toByteString
-- *Lenses
, 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)
-- *Conduits
-- |A conduit which takes as input bytestrings representing encoded
-- IRC messages, and decodes them to events. If decoding fails, the
-- original bytestring is just passed through.
ircDecoder :: Monad m => ConduitM ByteString (Either ByteString IrcEvent) m ()
ircDecoder = chunked .| awaitForever (yield . fromByteString)
-- |Like 'ircDecoder', but discards messages which could not be
-- decoded.
ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m ()
ircLossyDecoder = chunked .| awaitForever lossy
where
lossy bs = either (\_ -> return ()) yield $ fromByteString bs
-- |A conduit which takes as input irc messages, and produces as
-- output the encoded bytestring representation.
ircEncoder :: Monad m => ConduitM IrcMessage ByteString m ()
ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString)
-- |A conduit which rate limits output sent downstream. Awaiting on
-- this conduit will block, even if there is output ready, until the
-- time limit has passed.
floodProtector :: MonadIO m
=> NominalDiffTime
-- ^The minimum time between sending adjacent messages.
-> IO (ConduitM a a m ())
floodProtector delay = do
now <- getCurrentTime
mvar <- newMVar now
return $ conduit mvar
where
conduit mvar = awaitForever $ \val -> do
-- Block until the delay has passed
liftIO $ do
lastT <- takeMVar mvar
now <- getCurrentTime
let next = addUTCTime delay lastT
when (now < next) $
threadDelay . ceiling $ 1000000 * diffUTCTime next now
-- Update the time
now' <- getCurrentTime
putMVar mvar now'
-- Send the value downstream
yield val
-- *Networking
-- |Connect to a network server, without TLS, and concurrently run the
-- producer and consumer.
ircClient :: Int
-- ^The port number
-> ByteString
-- ^The hostname
-> IO ()
-- ^Any initialisation work (started concurrently with the
-- producer and consumer)
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-- ^The consumer of irc events
-> ConduitM () IrcMessage IO ()
-- ^The producer of irc messages
-> IO ()
ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host
-- |Run the IRC conduits using a provided connection.
--
-- Starts the connection and concurrently run the initialiser, event
-- consumer, and message sources. Terminates as soon as one throws an
-- exception.
ircWithConn :: ((AppData -> IO ()) -> IO ())
-- ^The initialised connection.
-> 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
-- **TLS
-- |Like 'ircClient', but with TLS. The TLS configuration used is
-- 'defaultTLSConfig'.
ircTLSClient :: Int
-> ByteString
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host)
-- |Like 'ircTLSClient', but takes the configuration to use, which
-- includes the host and port.
ircTLSClient' :: TLSClientConfig
-> IO ()
-> ConduitM (Either ByteString IrcEvent) Void IO ()
-> ConduitM () IrcMessage IO ()
-> IO ()
ircTLSClient' cfg = ircWithConn (runTLSClient cfg)
-- |The default TLS settings for 'ircTLSClient'.
defaultTLSConfig :: Int
-- ^The port number
-> ByteString
-- ^ The hostname
-> 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) ""
-- Make the TLS certificate validation a bit more generous. In
-- particular, allow self-signed certificates.
validate cs vc sid cc = do
-- First validate with the standard function
res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
-- Then strip out non-issues
return $ filter (`notElem` [UnknownCA, SelfSigned]) res
|
