update
[cloogle-irc.git] / IRC.icl
1 implementation module IRC
2
3 import StdList
4 import GenPrint
5 import StdOverloaded
6 import Data.Maybe
7 import Data.Either
8 import StdFunc
9 import StdString
10 import StdChar
11
12 import Text.Parsers.Simple.Core
13 import Text.Parsers.Simple.Chars
14 import Data.Tuple
15 import Control.Monad
16 import Control.Applicative
17 from Data.Functor import <$>
18
19 from Data.Func import $
20 from Text import class Text(concat), instance Text String
21 import qualified Text
22 from StdMisc import undef
23
24 jon :== 'Text'.join
25
26 derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either
27
28 //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
29 //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
30 Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY test with spaces\r\n"
31
32 (<+) infixr 5 :: a b -> String | toString a & toString b
33 (<+) a b = toString a +++ toString b
34
35 parseIRCMessage :: (String -> Either [Error] IRCMessage)
36 parseIRCMessage = parse parseMessage o fromString
37
38 parseMessage :: Parser Char IRCMessage
39 parseMessage = optional (parseEither parseHost parseUser) <* spaceParser
40 >>= \mprefix->parseCommand
41 <* pToken '\r' <* pToken '\n'
42 >>= \cmd->pure {IRCMessage | irc_prefix=mprefix, irc_command=cmd}
43
44 spaceParser :: Parser Char [Char]
45 spaceParser = pMany $ pToken ' '
46
47 parseServer :: Parser Char String
48 parseServer = pFail
49
50 parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
51 parseEither p q = Left <$> p <|> Right <$> q
52
53 parseUser :: Parser Char IRCUser
54 parseUser = pToken ':' >>| parseNick
55 >>= \nick->optional (pToken '!' >>| parseUsr)
56 >>= \muser->optional (pToken '@' >>| parseHost)
57 >>= \mhost->pure {IRCUser | irc_nick=nick, irc_user=muser, irc_host=mhost}
58
59 parseUsr :: Parser Char String
60 parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])
61
62 parseNick :: Parser Char String
63 parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial)
64 >>= \cs->pure (toString [c:cs])
65
66 pSpecial :: Parser Char Char
67 pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
68
69 parseHost :: Parser Char String
70 parseHost = parseName
71 >>= \nm->pMany (pToken '.' >>| parseName)
72 >>= \nms->pure (concat [nm:nms])
73 where
74 parseName :: Parser Char String
75 parseName = toString <$> pSome (pAlpha <|> pDigit <|> pToken '.')
76
77 instance toString IRCMessage where
78 toString m = maybe "" (\s->either id ((<+) ":") s <+ " ") m.irc_prefix <+ m.irc_command
79
80 instance toString IRCUser where
81 toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
82 <+ maybe "" ((<+) "@") m.irc_host
83
84 cons :: a [a] -> [a]
85 cons a as = [a:as]
86
87 pMiddle :: Parser Char String
88 pMiddle = fmap toString $
89 spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal)
90
91 pTrailing :: Parser Char String
92 pTrailing = fmap toString $
93 spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal])
94
95 pParam :: Parser Char String
96 pParam = pMiddle <|> pTrailing
97
98 pNoneOf :: [a] -> Parser a a | Eq a
99 pNoneOf l = pSatisfy (not o flip isMember l)
100
101 pNotSatisfy :: (a -> Bool) -> Parser a a | Eq a
102 pNotSatisfy f = pSatisfy (not o f)
103
104 pInt :: Parser Char Int
105 pInt = toInt o toString <$> (spaceParser >>| pSome pDigit)
106
107 illegal :: [Char]
108 illegal = ['\x00','\r','\n']
109
110 pCommand :: String -> Parser Char [Char]
111 pCommand s = pList (map pToken $ fromString s)
112
113 pCommand0 :: String IRCCommand -> Parser Char IRCCommand
114 pCommand0 s c = pCommand s >>| pure c
115
116 pCommand1 :: String (Parser Char a) (a -> IRCCommand) -> Parser Char IRCCommand
117 pCommand1 s p c = pCommand s >>| liftM c p
118
119 pCommand2 :: String (Parser Char a) (Parser Char b) (a b -> IRCCommand) -> Parser Char IRCCommand
120 pCommand2 s p q c = pCommand s >>| liftM2 c p q
121
122 pCommand3 :: String (Parser Char a) (Parser Char b) (Parser Char c) (a b c -> IRCCommand) -> Parser Char IRCCommand
123 pCommand3 s p q r c = pCommand s >>| liftM3 c p q r
124
125 pCommand4 :: String (Parser Char a) (Parser Char b) (Parser Char c) (Parser Char d) (a b c d -> IRCCommand) -> Parser Char IRCCommand
126 pCommand4 s p q r t c = pCommand s >>| liftM4 c p q r t
127
128 pCommand5 :: String (Parser Char a) (Parser Char b) (Parser Char c) (Parser Char d) (Parser Char e) (a b c d e -> IRCCommand) -> Parser Char IRCCommand
129 pCommand5 s p q r t u c = pCommand s >>| liftM5 c p q r t u
130
131 pMode :: Parser Char String
132 pMode = toString <$> pSome (pOneOf ['+','-','o','p','i','t','n','b','v','w','s'])
133
134 parseCommand :: Parser Char IRCCommand
135 parseCommand =
136 pCommand1 "ADMIN" (optional pMiddle) ADMIN
137 <|> pCommand1 "AWAY" pParam AWAY
138 <|> pCommand2 "CONNECT" pParam (optional $ liftM2 tuple pInt (optional pParam)) CONNECT
139 <|> pCommand0 "DIE" DIE
140 <|> pCommand1 "ERROR" pParam ERROR
141 <|> pCommand1 "INFO" (optional pParam) INFO
142 <|> pCommand2 "INVITE" pMiddle pMiddle INVITE
143 <|> pCommand1 "ISON" (pSome pMiddle) ISON
144 <|> pCommand1 "JOIN" (pSepBy (liftM2 tuple pMiddle $ optional pMiddle) pComma) JOIN
145 <|> pCommand3 "KICK" pMiddle pMiddle (optional pParam) KICK
146 <|> pCommand2 "KILL" pMiddle pParam KILL
147 <|> pCommand1 "LINKS" (optional $ liftM2 tuple (optional pMiddle) pMiddle) LINKS
148 <|> pCommand1 "LIST" (optional $ liftM2 tuple (pSepBy pMiddle pComma) $ optional pMiddle) LIST
149 <|> pCommand1 "LUSERS" (optional $ liftM2 tuple pMiddle $ optional pMiddle) LUSERS
150 <|> pCommand5 "MODE" pMiddle pMode (optional pMiddle) (optional pMiddle) (optional pMiddle) MODE
151 <|> pCommand1 "MOTD" (optional pMiddle) MOTD
152 <|> pCommand1 "NAMES" (pSepBy pMiddle pComma) NAMES
153 //NJOIN
154 //NOTICE String String
155 //OPER String String
156 //PART [String]
157 //PASS String
158 <|> pCommand2 "PING" pMiddle (optional pMiddle) PING
159 <|> pCommand2 "PONG" pMiddle (optional pMiddle) PONG
160 <|> pCommand2 "PRIVMSG" (pSepBy pMiddle pComma) pParam PRIVMSG
161 <|> pCommand1 "QUIT" (optional pParam) QUIT
162 //REHASH
163 //RESTART
164 //SERVER
165 //SERVICE String String String String
166 //SERVLIST (Maybe (String, Maybe String))
167 //SQUERY String String
168 //SQUIRT
169 //SQUIT String String
170 //STATS (Maybe (String, Maybe String))
171 //SUMMON String (Maybe (String, Maybe String))
172 //TIME (Maybe String)
173 //TOPIC String (Maybe String)
174 //TRACE (Maybe String)
175 <|> pCommand3 "USER" pMiddle pMiddle (pMiddle >>| pParam) USER
176 //USERHOST [String]
177 //USERS (Maybe String)
178 //VERSION (Maybe String)
179 //WALLOPS String
180 //WHO (Maybe String)
181 //WHOIS (Maybe String) [String]
182 //WHOWAS (Maybe String) [String]
183
184 instance toString IRCCommand where
185 toString r = flip (+++) "\r\n" case r of
186 //ADMIN (Maybe String)
187 //AWAY String
188 //CONNECT String (Maybe (Int, Maybe String))
189 //DIE
190 //ERROR String
191 //INFO (Maybe String)
192 //INVITE String String
193 //ISON [String]
194 JOIN chs = "JOIN " +++ (if (isEmpty chs) "0"
195 (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs]))
196 //KICK String String (Maybe String)
197 //KILL String String
198 //LINKS (Maybe (Maybe String, String))
199 //LIST (Maybe ([String], Maybe String))
200 //LUSERS (Maybe (String, Maybe String))
201 //MODE String String (Maybe String) (Maybe String) (Maybe String)
202 //MOTD (Maybe String)
203 //NAMES [String]
204 NICK n ms = jon " " ["NICK", n]
205 //NJOIN
206 //NOTICE String String
207 //OPER String String
208 //PART [String]
209 //PASS String
210 PING a mb = jon " " ["PING",a:maybeToList mb]
211 PONG a mb = jon " " ["PONG",a:maybeToList mb]
212 PRIVMSG dest msg = undef //jon " " ["PRIVMSG", dest, ":"+++msg]
213 QUIT msg = jon " " ["QUIT":maybeToList msg]
214 //REHASH
215 //RESTART
216 //SERVER
217 //SERVICE String String String String
218 //SERVLIST (Maybe (String, Maybe String))
219 //SQUERY String String
220 //SQUIRT
221 //SQUIT String String
222 //STATS (Maybe (String, Maybe String))
223 //SUMMON String (Maybe (String, Maybe String))
224 //TIME (Maybe String)
225 //TOPIC String (Maybe String)
226 //TRACE (Maybe String)
227 USER login mode rn = jon " " ["USER", login, mode, "*", ":"+++rn]
228 //USERHOST [String]
229 //USERS (Maybe String)
230 //VERSION (Maybe String)
231 //WALLOPS String
232 //WHO (Maybe String)
233 //WHOIS (Maybe String) [String]
234 //WHOWAS (Maybe String) [String]
235 _ = printToString r
236
237
238 instance toString IRCReplies where toString r = printToString r
239 instance toString IRCErrors where toString r = printToString r
240
241 instance fromInt IRCReplies where
242 fromInt r = case r of
243 1 = RPL_WELCOME
244 2 = RPL_YOURHOST
245 3 = RPL_CREATED
246 4 = RPL_MYINFO
247 5 = RPL_BOUNCE
248 200 = RPL_TRACELINK
249 201 = RPL_TRACECONNECTING
250 202 = RPL_TRACEHANDSHAKE
251 203 = RPL_TRACEUNKNOWN
252 204 = RPL_TRACEOPERATOR
253 205 = RPL_TRACEUSER
254 206 = RPL_TRACESERVER
255 207 = RPL_TRACESERVICE
256 208 = RPL_TRACENEWTYPE
257 209 = RPL_TRACECLASS
258 210 = RPL_TRACERECONNECT
259 211 = RPL_STATSLINKINFO
260 212 = RPL_STATSCOMMANDS
261 219 = RPL_ENDOFSTATS
262 221 = RPL_UMODEIS
263 234 = RPL_SERVLIST
264 235 = RPL_SERVLISTEND
265 242 = RPL_STATSUPTIME
266 243 = RPL_STATSOLINE
267 251 = RPL_LUSERCLIENT
268 252 = RPL_LUSEROP
269 253 = RPL_LUSERUNKNOWN
270 254 = RPL_LUSERCHANNELS
271 255 = RPL_LUSERME
272 256 = RPL_ADMINME
273 257 = RPL_ADMINLOC1
274 258 = RPL_ADMINLOC2
275 259 = RPL_ADMINEMAIL
276 261 = RPL_TRACELOG
277 262 = RPL_TRACEEND
278 263 = RPL_TRYAGAIN
279 301 = RPL_AWAY
280 302 = RPL_USERHOST
281 303 = RPL_ISON
282 304 = RPL_UNAWAY
283 305 = RPL_NOWAWAY
284 311 = RPL_WHOISUSER
285 312 = RPL_WHOISSERVER
286 313 = RPL_WHOISOPERATOR
287 314 = RPL_WHOWASUSER
288 315 = RPL_ENDOFWHO
289 317 = RPL_WHOISIDLE
290 318 = RPL_ENDOFWHOIS
291 319 = RPL_WHOISCHANNELS
292 321 = RPL_LISTSTART
293 322 = RPL_LIST
294 323 = RPL_LISTEND
295 324 = RPL_CHANNELMODEIS
296 325 = RPL_UNIQOPIS
297 331 = RPL_NOTOPIC
298 332 = RPL_TOPIC
299 341 = RPL_INVITING
300 342 = RPL_SUMMONING
301 346 = RPL_INVITELIST
302 347 = RPL_ENDOFINVITELIST
303 348 = RPL_EXCEPTLIST
304 349 = RPL_ENDOFEXCEPTLIST
305 351 = RPL_VERSION
306 352 = RPL_WHOREPLY
307 353 = RPL_NAMREPLY
308 364 = RPL_LINKS
309 365 = RPL_ENDOFLINKS
310 366 = RPL_ENDOFNAMES
311 367 = RPL_BANLIST
312 368 = RPL_ENDOFBANLIST
313 369 = RPL_ENDOFWHOWAS
314 371 = RPL_INFO
315 372 = RPL_MOTD
316 374 = RPL_ENDOFINFO
317 375 = RPL_MOTDSTART
318 376 = RPL_ENDOFMOTD
319 381 = RPL_YOUREOPER
320 382 = RPL_REHASHING
321 383 = RPL_YOURESERVICE
322 391 = RPL_TIME
323 392 = RPL_USERSSTART
324 393 = RPL_USERS
325 394 = RPL_ENDOFUSERS
326 395 = RPL_NOUSERS
327 _ = undef
328
329 instance toInt IRCReplies where
330 toInt r = case r of
331 RPL_WELCOME = 1
332 RPL_YOURHOST = 2
333 RPL_CREATED = 3
334 RPL_MYINFO = 4
335 RPL_BOUNCE = 5
336 RPL_TRACELINK = 200
337 RPL_TRACECONNECTING = 201
338 RPL_TRACEHANDSHAKE = 202
339 RPL_TRACEUNKNOWN = 203
340 RPL_TRACEOPERATOR = 204
341 RPL_TRACEUSER = 205
342 RPL_TRACESERVER = 206
343 RPL_TRACESERVICE = 207
344 RPL_TRACENEWTYPE = 208
345 RPL_TRACECLASS = 209
346 RPL_TRACERECONNECT = 210
347 RPL_STATSLINKINFO = 211
348 RPL_STATSCOMMANDS = 212
349 RPL_ENDOFSTATS = 219
350 RPL_UMODEIS = 221
351 RPL_SERVLIST = 234
352 RPL_SERVLISTEND = 234
353 RPL_STATSUPTIME = 242
354 RPL_STATSOLINE = 243
355 RPL_LUSERCLIENT = 251
356 RPL_LUSEROP = 252
357 RPL_LUSERUNKNOWN = 253
358 RPL_LUSERCHANNELS = 254
359 RPL_LUSERME = 255
360 RPL_ADMINME = 256
361 RPL_ADMINLOC1 = 257
362 RPL_ADMINLOC2 = 258
363 RPL_ADMINEMAIL = 259
364 RPL_TRACELOG = 261
365 RPL_TRACEEND = 262
366 RPL_TRYAGAIN = 263
367 RPL_AWAY = 301
368 RPL_USERHOST = 302
369 RPL_ISON = 303
370 RPL_UNAWAY = 304
371 RPL_NOWAWAY = 305
372 RPL_WHOISUSER = 311
373 RPL_WHOISSERVER = 312
374 RPL_WHOISOPERATOR = 313
375 RPL_WHOWASUSER = 314
376 RPL_ENDOFWHO = 315
377 RPL_WHOISIDLE = 317
378 RPL_ENDOFWHOIS = 318
379 RPL_WHOISCHANNELS = 319
380 RPL_LISTSTART = 321
381 RPL_LIST = 322
382 RPL_LISTEND = 323
383 RPL_CHANNELMODEIS = 324
384 RPL_UNIQOPIS = 325
385 RPL_NOTOPIC = 331
386 RPL_TOPIC = 332
387 RPL_INVITING = 341
388 RPL_SUMMONING = 342
389 RPL_INVITELIST = 346
390 RPL_ENDOFINVITELIST = 347
391 RPL_EXCEPTLIST = 348
392 RPL_ENDOFEXCEPTLIST = 349
393 RPL_VERSION = 351
394 RPL_WHOREPLY = 352
395 RPL_NAMREPLY = 353
396 RPL_LINKS = 364
397 RPL_ENDOFLINKS = 365
398 RPL_ENDOFNAMES = 366
399 RPL_BANLIST = 367
400 RPL_ENDOFBANLIST = 367
401 RPL_ENDOFWHOWAS = 369
402 RPL_INFO = 371
403 RPL_MOTD = 372
404 RPL_ENDOFINFO = 374
405 RPL_MOTDSTART = 375
406 RPL_ENDOFMOTD = 376
407 RPL_YOUREOPER = 381
408 RPL_REHASHING = 382
409 RPL_YOURESERVICE = 383
410 RPL_TIME = 391
411 RPL_USERSSTART = 392
412 RPL_USERS = 393
413 RPL_ENDOFUSERS = 394
414 RPL_NOUSERS = 395
415
416 instance fromInt IRCErrors where
417 fromInt r = case r of
418 401 = ERR_NOSUCHNICK
419 402 = ERR_NOSUCHSERVER
420 403 = ERR_NOSUCHCHANNEL
421 404 = ERR_CANNOTSENDTOCHAN
422 405 = ERR_TOOMANYCHANNELS
423 406 = ERR_WASNOSUCHNICK
424 407 = ERR_TOOMANYTARGETS
425 408 = ERR_NOSUCHSERVICE
426 409 = ERR_NOORIGIN
427 411 = ERR_NORECIPIENT
428 412 = ERR_NOTEXTTOSEND
429 413 = ERR_NOTOPLEVEL
430 414 = ERR_WILDTOPLEVEL
431 415 = ERR_BADMASK
432 421 = ERR_UNKNOWNCOMMAND
433 422 = ERR_NOMOTD
434 423 = ERR_NOADMININFO
435 424 = ERR_FILEERROR
436 431 = ERR_NONICKNAMEGIVEN
437 432 = ERR_ERRONEUSNICKNAME
438 433 = ERR_NICKNAMEINUSE
439 436 = ERR_NICKCOLLISION
440 437 = ERR_UNAVAILRESOURCE
441 441 = ERR_USERNOTINCHANNEL
442 442 = ERR_NOTONCHANNEL
443 443 = ERR_USERONCHANNEL
444 444 = ERR_NOLOGIN
445 445 = ERR_SUMMONDISABLED
446 446 = ERR_USERSDISABLED
447 451 = ERR_NOTREGISTERED
448 461 = ERR_NEEDMOREPARAMS
449 462 = ERR_ALREADYREGISTRED
450 463 = ERR_NOPERMFORHOST
451 464 = ERR_PASSWDMISMATCH
452 465 = ERR_YOUREBANNEDCREEP
453 466 = ERR_YOUWILLBEBANNED
454 467 = ERR_KEYSET
455 471 = ERR_CHANNELISFULL
456 472 = ERR_UNKNOWNMODE
457 473 = ERR_INVITEONLYCHAN
458 474 = ERR_BANNEDFROMCHAN
459 475 = ERR_BADCHANNELKEY
460 476 = ERR_BADCHANMASK
461 477 = ERR_NOCHANMODES
462 478 = ERR_BANLISTFULL
463 481 = ERR_NOPRIVILEGES
464 482 = ERR_CHANOPRIVSNEEDED
465 483 = ERR_CANTKILLSERVER
466 484 = ERR_RESTRICTED
467 485 = ERR_UNIQOPPRIVSNEEDED
468 491 = ERR_NOOPERHOST
469 501 = ERR_UMODEUNKNOWNFLAG
470 502 = ERR_USERSDONTMATCH
471
472 instance toInt IRCErrors where
473 toInt r = case r of
474 ERR_NOSUCHNICK = 401
475 ERR_NOSUCHSERVER = 402
476 ERR_NOSUCHCHANNEL = 403
477 ERR_CANNOTSENDTOCHAN = 404
478 ERR_TOOMANYCHANNELS = 405
479 ERR_WASNOSUCHNICK = 406
480 ERR_TOOMANYTARGETS = 407
481 ERR_NOSUCHSERVICE = 408
482 ERR_NOORIGIN = 409
483 ERR_NORECIPIENT = 411
484 ERR_NOTEXTTOSEND = 412
485 ERR_NOTOPLEVEL = 413
486 ERR_WILDTOPLEVEL = 414
487 ERR_BADMASK = 415
488 ERR_UNKNOWNCOMMAND = 421
489 ERR_NOMOTD = 422
490 ERR_NOADMININFO = 423
491 ERR_FILEERROR = 424
492 ERR_NONICKNAMEGIVEN = 431
493 ERR_ERRONEUSNICKNAME = 432
494 ERR_NICKNAMEINUSE = 433
495 ERR_NICKCOLLISION = 436
496 ERR_UNAVAILRESOURCE = 437
497 ERR_USERNOTINCHANNEL = 441
498 ERR_NOTONCHANNEL = 442
499 ERR_USERONCHANNEL = 443
500 ERR_NOLOGIN = 444
501 ERR_SUMMONDISABLED = 445
502 ERR_USERSDISABLED = 446
503 ERR_NOTREGISTERED = 451
504 ERR_NEEDMOREPARAMS = 461
505 ERR_ALREADYREGISTRED = 462
506 ERR_NOPERMFORHOST = 463
507 ERR_PASSWDMISMATCH = 464
508 ERR_YOUREBANNEDCREEP = 465
509 ERR_YOUWILLBEBANNED = 466
510 ERR_KEYSET = 467
511 ERR_CHANNELISFULL = 471
512 ERR_UNKNOWNMODE = 472
513 ERR_INVITEONLYCHAN = 473
514 ERR_BANNEDFROMCHAN = 474
515 ERR_BADCHANNELKEY = 475
516 ERR_BADCHANMASK = 476
517 ERR_NOCHANMODES = 477
518 ERR_BANLISTFULL = 478
519 ERR_NOPRIVILEGES = 481
520 ERR_CHANOPRIVSNEEDED = 482
521 ERR_CANTKILLSERVER = 483
522 ERR_RESTRICTED = 484
523 ERR_UNIQOPPRIVSNEEDED = 485
524 ERR_NOOPERHOST = 491
525 ERR_UMODEUNKNOWNFLAG = 501
526 ERR_USERSDONTMATCH = 502