1 implementation module IRC
13 import Text.Parsers.Simple.Core
14 import Text.Parsers.Simple.Chars
17 import Control.Applicative
18 from Data.Functor import <$>
20 from Data.Func import $
21 from Text import class Text(indexOf,concat), instance Text String
23 from StdMisc import undef
27 derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either
29 //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
30 //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
31 //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n"
32 //Start = runParser parseMessage $ fromString ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n"
33 Start = runParser parseMessage $ fromString ":cherryh.freenode.net QUIT\r\n"
35 (<+) infixr 5 :: a b -> String | toString a & toString b
36 (<+) a b = toString a +++ toString b
38 parseIRCMessage :: (String -> Either [Error] IRCMessage)
39 parseIRCMessage = parse parseMessage o fromString
41 parseMessage :: Parser Char IRCMessage
42 parseMessage = optional (parseEither parseHost parseUser) <* spaceParser
43 >>= \mprefix->parseCommand
44 <* pToken '\r' <* pToken '\n'
45 >>= \cmd->pure {IRCMessage | irc_prefix=mprefix, irc_command=cmd}
47 spaceParser :: Parser Char [Char]
48 spaceParser = pMany $ pToken ' '
50 parseServer :: Parser Char String
53 parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
54 parseEither p q = Left <$> p <|> Right <$> q
56 parseUser :: Parser Char IRCUser
57 parseUser = pToken ':' >>| parseNick
58 >>= \nick->optional (pToken '!' >>| parseUsr)
59 >>= \muser->optional (pToken '@' >>| parseHost)
60 >>= \mhost->pure {IRCUser | irc_nick=nick, irc_user=muser, irc_host=mhost}
62 parseUsr :: Parser Char String
63 parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])
65 parseNick :: Parser Char String
66 parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial)
67 >>= \cs->pure (toString [c:cs])
69 pSpecial :: Parser Char Char
70 pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
72 parseHost :: Parser Char String
73 parseHost = pToken ':' >>| parseName
74 >>= \nm->pMany (pToken '.' >>| parseName)
75 >>= \nms->pure (concat [nm:nms])
77 parseName :: Parser Char String
78 parseName = toString <$> pSome (pAlpha <|> pDigit <|> pToken '.')
80 instance toString IRCMessage where
81 toString m = maybe "" (\s->either id ((<+) ":") s <+ " ") m.irc_prefix <+ m.irc_command
83 instance toString IRCUser where
84 toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
85 <+ maybe "" ((<+) "@") m.irc_host
90 pMiddle :: Parser Char String
91 pMiddle = fmap toString $
92 spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal])
94 pTrailing :: Parser Char String
95 pTrailing = fmap toString $
96 spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal)
98 pParam :: Parser Char String
99 pParam = pMiddle <|> pTrailing
101 pNoneOf :: [a] -> Parser a a | Eq a
102 pNoneOf l = pSatisfy (not o flip isMember l)
104 pNotSatisfy :: (a -> Bool) -> Parser a a | Eq a
105 pNotSatisfy f = pSatisfy (not o f)
107 pInt :: Parser Char Int
108 pInt = toInt o toString <$> (spaceParser >>| pSome pDigit)
111 illegal = ['\x00','\r','\n']
113 pCommand :: String -> Parser Char [Char]
114 pCommand s = pList (map pToken $ fromString s)
116 pCommand0 :: String IRCCommand -> Parser Char IRCCommand
117 pCommand0 s c = pCommand s >>| pure c
119 pCommand1 :: String (Parser Char a) (a -> IRCCommand) -> Parser Char IRCCommand
120 pCommand1 s p c = pCommand s >>| liftM c p
122 pCommand2 :: String (Parser Char a) (Parser Char b) (a b -> IRCCommand) -> Parser Char IRCCommand
123 pCommand2 s p q c = pCommand s >>| liftM2 c p q
125 pCommand3 :: String (Parser Char a) (Parser Char b) (Parser Char c) (a b c -> IRCCommand) -> Parser Char IRCCommand
126 pCommand3 s p q r c = pCommand s >>| liftM3 c p q r
128 pCommand4 :: String (Parser Char a) (Parser Char b) (Parser Char c) (Parser Char d) (a b c d -> IRCCommand) -> Parser Char IRCCommand
129 pCommand4 s p q r t c = pCommand s >>| liftM4 c p q r t
131 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
132 pCommand5 s p q r t u c = pCommand s >>| liftM5 c p q r t u
134 pMode :: Parser Char String
135 pMode = toString <$> pSome (pOneOf ['+','-','o','p','i','t','n','b','v','w','s'])
137 parseCommand :: Parser Char IRCCommand
139 pCommand1 "ADMIN" (optional pMiddle) ADMIN
140 <|> pCommand1 "AWAY" pParam AWAY
141 <|> pCommand2 "CONNECT" pParam (optional $ liftM2 tuple pInt (optional pParam)) CONNECT
142 <|> pCommand0 "DIE" DIE
143 <|> pCommand1 "ERROR" pParam ERROR
144 <|> pCommand1 "INFO" (optional pParam) INFO
145 <|> pCommand2 "INVITE" pMiddle pMiddle INVITE
146 <|> pCommand1 "ISON" (pSome pMiddle) ISON
147 <|> pCommand1 "JOIN" (pSepBy (liftM2 tuple pMiddle $ optional pMiddle) pComma) JOIN
148 <|> pCommand3 "KICK" pMiddle pMiddle (optional pParam) KICK
149 <|> pCommand2 "KILL" pMiddle pParam KILL
150 <|> pCommand1 "LINKS" (optional $ liftM2 tuple (optional pMiddle) pMiddle) LINKS
151 <|> pCommand1 "LIST" (optional $ liftM2 tuple (pSepBy pMiddle pComma) $ optional pMiddle) LIST
152 <|> pCommand1 "LUSERS" (optional $ liftM2 tuple pMiddle $ optional pMiddle) LUSERS
153 <|> pCommand5 "MODE" pMiddle pMode (optional pMiddle) (optional pMiddle) (optional pMiddle) MODE
154 <|> pCommand1 "MOTD" (optional pMiddle) MOTD
155 <|> pCommand1 "NAMES" (pSepBy pMiddle pComma) NAMES
157 <|> pCommand2 "NOTICE" pParam pParam NOTICE
161 <|> pCommand2 "PING" pMiddle (optional pMiddle) PING
162 <|> pCommand2 "PONG" pMiddle (optional pMiddle) PONG
163 <|> pCommand2 "PRIVMSG" (pSepBy pMiddle pComma) pParam PRIVMSG
164 <|> pCommand1 "QUIT" (optional pParam) QUIT
168 //SERVICE String String String String
169 //SERVLIST (Maybe (String, Maybe String))
170 //SQUERY String String
172 //SQUIT String String
173 //STATS (Maybe (String, Maybe String))
174 //SUMMON String (Maybe (String, Maybe String))
175 //TIME (Maybe String)
176 //TOPIC String (Maybe String)
177 //TRACE (Maybe String)
178 <|> pCommand3 "USER" pMiddle pMiddle (pMiddle >>| pParam) USER
180 //USERS (Maybe String)
181 //VERSION (Maybe String)
184 //WHOIS (Maybe String) [String]
185 //WHOWAS (Maybe String) [String]
187 instance toString IRCCommand where
188 toString r = jon " " (print r) +++ "\r\n"
190 print :: IRCCommand -> [String]
192 ADMIN mm = ["ADMIN":maybeToList mm]
194 //CONNECT String (Maybe (Int, Maybe String))
197 //INFO (Maybe String)
198 //INVITE String String
200 JOIN chs = ["JOIN",if (isEmpty chs) "0"
201 (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs])]
202 //KICK String String (Maybe String)
204 //LINKS (Maybe (Maybe String, String))
205 //LIST (Maybe ([String], Maybe String))
206 //LUSERS (Maybe (String, Maybe String))
207 //MODE String String (Maybe String) (Maybe String) (Maybe String)
208 //MOTD (Maybe String)
210 NICK n ms = ["NICK", n]
212 //NOTICE String String
216 PING a mb = ["PING",a:maybeToList mb]
217 PONG a mb = ["PONG",a:maybeToList mb]
218 PRIVMSG dest msg = ["PRIVMSG",jon "," dest,formatMSG msg]
219 QUIT msg = ["QUIT":maybeToList msg]
223 //SERVICE String String String String
224 //SERVLIST (Maybe (String, Maybe String))
225 //SQUERY String String
227 //SQUIT String String
228 //STATS (Maybe (String, Maybe String))
229 //SUMMON String (Maybe (String, Maybe String))
230 //TIME (Maybe String)
231 //TOPIC String (Maybe String)
232 //TRACE (Maybe String)
233 USER login mode rn = ["USER", login, mode, "*", ":"+++rn]
235 //USERS (Maybe String)
236 //VERSION (Maybe String)
239 //WHOIS (Maybe String) [String]
240 //WHOWAS (Maybe String) [String]
241 _ = [printToString r]
243 formatMSG :: String -> String
244 formatMSG s = if (indexOf " " s > 0 || indexOf " " s > 0) (":" +++ s) s
247 instance toString IRCReplies where toString r = printToString r
248 instance toString IRCErrors where toString r = printToString r
250 instance fromInt IRCReplies where
251 fromInt r = case r of
258 201 = RPL_TRACECONNECTING
259 202 = RPL_TRACEHANDSHAKE
260 203 = RPL_TRACEUNKNOWN
261 204 = RPL_TRACEOPERATOR
263 206 = RPL_TRACESERVER
264 207 = RPL_TRACESERVICE
265 208 = RPL_TRACENEWTYPE
267 210 = RPL_TRACERECONNECT
268 211 = RPL_STATSLINKINFO
269 212 = RPL_STATSCOMMANDS
273 235 = RPL_SERVLISTEND
274 242 = RPL_STATSUPTIME
276 251 = RPL_LUSERCLIENT
278 253 = RPL_LUSERUNKNOWN
279 254 = RPL_LUSERCHANNELS
294 312 = RPL_WHOISSERVER
295 313 = RPL_WHOISOPERATOR
300 319 = RPL_WHOISCHANNELS
304 324 = RPL_CHANNELMODEIS
311 347 = RPL_ENDOFINVITELIST
313 349 = RPL_ENDOFEXCEPTLIST
321 368 = RPL_ENDOFBANLIST
322 369 = RPL_ENDOFWHOWAS
330 383 = RPL_YOURESERVICE
338 instance toInt IRCReplies where
346 RPL_TRACECONNECTING = 201
347 RPL_TRACEHANDSHAKE = 202
348 RPL_TRACEUNKNOWN = 203
349 RPL_TRACEOPERATOR = 204
351 RPL_TRACESERVER = 206
352 RPL_TRACESERVICE = 207
353 RPL_TRACENEWTYPE = 208
355 RPL_TRACERECONNECT = 210
356 RPL_STATSLINKINFO = 211
357 RPL_STATSCOMMANDS = 212
361 RPL_SERVLISTEND = 234
362 RPL_STATSUPTIME = 242
364 RPL_LUSERCLIENT = 251
366 RPL_LUSERUNKNOWN = 253
367 RPL_LUSERCHANNELS = 254
382 RPL_WHOISSERVER = 312
383 RPL_WHOISOPERATOR = 313
388 RPL_WHOISCHANNELS = 319
392 RPL_CHANNELMODEIS = 324
399 RPL_ENDOFINVITELIST = 347
401 RPL_ENDOFEXCEPTLIST = 349
409 RPL_ENDOFBANLIST = 367
410 RPL_ENDOFWHOWAS = 369
418 RPL_YOURESERVICE = 383
425 instance fromInt IRCErrors where
426 fromInt r = case r of
428 402 = ERR_NOSUCHSERVER
429 403 = ERR_NOSUCHCHANNEL
430 404 = ERR_CANNOTSENDTOCHAN
431 405 = ERR_TOOMANYCHANNELS
432 406 = ERR_WASNOSUCHNICK
433 407 = ERR_TOOMANYTARGETS
434 408 = ERR_NOSUCHSERVICE
436 411 = ERR_NORECIPIENT
437 412 = ERR_NOTEXTTOSEND
439 414 = ERR_WILDTOPLEVEL
441 421 = ERR_UNKNOWNCOMMAND
443 423 = ERR_NOADMININFO
445 431 = ERR_NONICKNAMEGIVEN
446 432 = ERR_ERRONEUSNICKNAME
447 433 = ERR_NICKNAMEINUSE
448 436 = ERR_NICKCOLLISION
449 437 = ERR_UNAVAILRESOURCE
450 441 = ERR_USERNOTINCHANNEL
451 442 = ERR_NOTONCHANNEL
452 443 = ERR_USERONCHANNEL
454 445 = ERR_SUMMONDISABLED
455 446 = ERR_USERSDISABLED
456 451 = ERR_NOTREGISTERED
457 461 = ERR_NEEDMOREPARAMS
458 462 = ERR_ALREADYREGISTRED
459 463 = ERR_NOPERMFORHOST
460 464 = ERR_PASSWDMISMATCH
461 465 = ERR_YOUREBANNEDCREEP
462 466 = ERR_YOUWILLBEBANNED
464 471 = ERR_CHANNELISFULL
465 472 = ERR_UNKNOWNMODE
466 473 = ERR_INVITEONLYCHAN
467 474 = ERR_BANNEDFROMCHAN
468 475 = ERR_BADCHANNELKEY
469 476 = ERR_BADCHANMASK
470 477 = ERR_NOCHANMODES
471 478 = ERR_BANLISTFULL
472 481 = ERR_NOPRIVILEGES
473 482 = ERR_CHANOPRIVSNEEDED
474 483 = ERR_CANTKILLSERVER
476 485 = ERR_UNIQOPPRIVSNEEDED
478 501 = ERR_UMODEUNKNOWNFLAG
479 502 = ERR_USERSDONTMATCH
481 instance toInt IRCErrors where
484 ERR_NOSUCHSERVER = 402
485 ERR_NOSUCHCHANNEL = 403
486 ERR_CANNOTSENDTOCHAN = 404
487 ERR_TOOMANYCHANNELS = 405
488 ERR_WASNOSUCHNICK = 406
489 ERR_TOOMANYTARGETS = 407
490 ERR_NOSUCHSERVICE = 408
492 ERR_NORECIPIENT = 411
493 ERR_NOTEXTTOSEND = 412
495 ERR_WILDTOPLEVEL = 414
497 ERR_UNKNOWNCOMMAND = 421
499 ERR_NOADMININFO = 423
501 ERR_NONICKNAMEGIVEN = 431
502 ERR_ERRONEUSNICKNAME = 432
503 ERR_NICKNAMEINUSE = 433
504 ERR_NICKCOLLISION = 436
505 ERR_UNAVAILRESOURCE = 437
506 ERR_USERNOTINCHANNEL = 441
507 ERR_NOTONCHANNEL = 442
508 ERR_USERONCHANNEL = 443
510 ERR_SUMMONDISABLED = 445
511 ERR_USERSDISABLED = 446
512 ERR_NOTREGISTERED = 451
513 ERR_NEEDMOREPARAMS = 461
514 ERR_ALREADYREGISTRED = 462
515 ERR_NOPERMFORHOST = 463
516 ERR_PASSWDMISMATCH = 464
517 ERR_YOUREBANNEDCREEP = 465
518 ERR_YOUWILLBEBANNED = 466
520 ERR_CHANNELISFULL = 471
521 ERR_UNKNOWNMODE = 472
522 ERR_INVITEONLYCHAN = 473
523 ERR_BANNEDFROMCHAN = 474
524 ERR_BADCHANNELKEY = 475
525 ERR_BADCHANMASK = 476
526 ERR_NOCHANMODES = 477
527 ERR_BANLISTFULL = 478
528 ERR_NOPRIVILEGES = 481
529 ERR_CHANOPRIVSNEEDED = 482
530 ERR_CANTKILLSERVER = 483
532 ERR_UNIQOPPRIVSNEEDED = 485
534 ERR_UMODEUNKNOWNFLAG = 501
535 ERR_USERSDONTMATCH = 502