1 implementation module IRC
12 import Text.Parsers.Simple.Core
13 import Text.Parsers.Simple.Chars
16 import Control.Applicative
17 from Data.Functor import <$>
19 from Data.Func import $
20 from Text import class Text(concat), instance Text String
22 from StdMisc import undef
26 derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either
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"
32 (<+) infixr 5 :: a b -> String | toString a & toString b
33 (<+) a b = toString a +++ toString b
35 parseIRCMessage :: (String -> Either [Error] IRCMessage)
36 parseIRCMessage = parse parseMessage o fromString
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}
44 spaceParser :: Parser Char [Char]
45 spaceParser = pMany $ pToken ' '
47 parseServer :: Parser Char String
50 parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
51 parseEither p q = Left <$> p <|> Right <$> q
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}
59 parseUsr :: Parser Char String
60 parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])
62 parseNick :: Parser Char String
63 parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial)
64 >>= \cs->pure (toString [c:cs])
66 pSpecial :: Parser Char Char
67 pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
69 parseHost :: Parser Char String
71 >>= \nm->pMany (pToken '.' >>| parseName)
72 >>= \nms->pure (concat [nm:nms])
74 parseName :: Parser Char String
75 parseName = toString <$> pSome (pAlpha <|> pDigit <|> pToken '.')
77 instance toString IRCMessage where
78 toString m = maybe "" (\s->either id ((<+) ":") s <+ " ") m.irc_prefix <+ m.irc_command
80 instance toString IRCUser where
81 toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
82 <+ maybe "" ((<+) "@") m.irc_host
87 pMiddle :: Parser Char String
88 pMiddle = fmap toString $
89 spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal)
91 pTrailing :: Parser Char String
92 pTrailing = fmap toString $
93 spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal])
95 pParam :: Parser Char String
96 pParam = pMiddle <|> pTrailing
98 pNoneOf :: [a] -> Parser a a | Eq a
99 pNoneOf l = pSatisfy (not o flip isMember l)
101 pNotSatisfy :: (a -> Bool) -> Parser a a | Eq a
102 pNotSatisfy f = pSatisfy (not o f)
104 pInt :: Parser Char Int
105 pInt = toInt o toString <$> (spaceParser >>| pSome pDigit)
108 illegal = ['\x00','\r','\n']
110 pCommand :: String -> Parser Char [Char]
111 pCommand s = pList (map pToken $ fromString s)
113 pCommand0 :: String IRCCommand -> Parser Char IRCCommand
114 pCommand0 s c = pCommand s >>| pure c
116 pCommand1 :: String (Parser Char a) (a -> IRCCommand) -> Parser Char IRCCommand
117 pCommand1 s p c = pCommand s >>| liftM c p
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
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
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
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
131 pMode :: Parser Char String
132 pMode = toString <$> pSome (pOneOf ['+','-','o','p','i','t','n','b','v','w','s'])
134 parseCommand :: Parser Char IRCCommand
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
154 //NOTICE String 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
165 //SERVICE String String String String
166 //SERVLIST (Maybe (String, Maybe String))
167 //SQUERY String String
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
177 //USERS (Maybe String)
178 //VERSION (Maybe String)
181 //WHOIS (Maybe String) [String]
182 //WHOWAS (Maybe String) [String]
184 instance toString IRCCommand where
185 toString r = flip (+++) "\r\n" case r of
186 //ADMIN (Maybe String)
188 //CONNECT String (Maybe (Int, Maybe String))
191 //INFO (Maybe String)
192 //INVITE String String
194 JOIN chs = "JOIN " +++ (if (isEmpty chs) "0"
195 (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs]))
196 //KICK String String (Maybe 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)
204 NICK n ms = jon " " ["NICK", n]
206 //NOTICE String 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]
217 //SERVICE String String String String
218 //SERVLIST (Maybe (String, Maybe String))
219 //SQUERY String String
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]
229 //USERS (Maybe String)
230 //VERSION (Maybe String)
233 //WHOIS (Maybe String) [String]
234 //WHOWAS (Maybe String) [String]
238 instance toString IRCReplies where toString r = printToString r
239 instance toString IRCErrors where toString r = printToString r
241 instance fromInt IRCReplies where
242 fromInt r = case r of
249 201 = RPL_TRACECONNECTING
250 202 = RPL_TRACEHANDSHAKE
251 203 = RPL_TRACEUNKNOWN
252 204 = RPL_TRACEOPERATOR
254 206 = RPL_TRACESERVER
255 207 = RPL_TRACESERVICE
256 208 = RPL_TRACENEWTYPE
258 210 = RPL_TRACERECONNECT
259 211 = RPL_STATSLINKINFO
260 212 = RPL_STATSCOMMANDS
264 235 = RPL_SERVLISTEND
265 242 = RPL_STATSUPTIME
267 251 = RPL_LUSERCLIENT
269 253 = RPL_LUSERUNKNOWN
270 254 = RPL_LUSERCHANNELS
285 312 = RPL_WHOISSERVER
286 313 = RPL_WHOISOPERATOR
291 319 = RPL_WHOISCHANNELS
295 324 = RPL_CHANNELMODEIS
302 347 = RPL_ENDOFINVITELIST
304 349 = RPL_ENDOFEXCEPTLIST
312 368 = RPL_ENDOFBANLIST
313 369 = RPL_ENDOFWHOWAS
321 383 = RPL_YOURESERVICE
329 instance toInt IRCReplies where
337 RPL_TRACECONNECTING = 201
338 RPL_TRACEHANDSHAKE = 202
339 RPL_TRACEUNKNOWN = 203
340 RPL_TRACEOPERATOR = 204
342 RPL_TRACESERVER = 206
343 RPL_TRACESERVICE = 207
344 RPL_TRACENEWTYPE = 208
346 RPL_TRACERECONNECT = 210
347 RPL_STATSLINKINFO = 211
348 RPL_STATSCOMMANDS = 212
352 RPL_SERVLISTEND = 234
353 RPL_STATSUPTIME = 242
355 RPL_LUSERCLIENT = 251
357 RPL_LUSERUNKNOWN = 253
358 RPL_LUSERCHANNELS = 254
373 RPL_WHOISSERVER = 312
374 RPL_WHOISOPERATOR = 313
379 RPL_WHOISCHANNELS = 319
383 RPL_CHANNELMODEIS = 324
390 RPL_ENDOFINVITELIST = 347
392 RPL_ENDOFEXCEPTLIST = 349
400 RPL_ENDOFBANLIST = 367
401 RPL_ENDOFWHOWAS = 369
409 RPL_YOURESERVICE = 383
416 instance fromInt IRCErrors where
417 fromInt r = case r of
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
427 411 = ERR_NORECIPIENT
428 412 = ERR_NOTEXTTOSEND
430 414 = ERR_WILDTOPLEVEL
432 421 = ERR_UNKNOWNCOMMAND
434 423 = ERR_NOADMININFO
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
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
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
467 485 = ERR_UNIQOPPRIVSNEEDED
469 501 = ERR_UMODEUNKNOWNFLAG
470 502 = ERR_USERSDONTMATCH
472 instance toInt IRCErrors where
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
483 ERR_NORECIPIENT = 411
484 ERR_NOTEXTTOSEND = 412
486 ERR_WILDTOPLEVEL = 414
488 ERR_UNKNOWNCOMMAND = 421
490 ERR_NOADMININFO = 423
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
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
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
523 ERR_UNIQOPPRIVSNEEDED = 485
525 ERR_UMODEUNKNOWNFLAG = 501
526 ERR_USERSDONTMATCH = 502