1 implementation module IRC
16 import Text.Parsers.Simple.Core
17 import Text.Parsers.Simple.Chars
20 import Control.Applicative
21 from Data.Functor import <$>
23 from Data.Func import $
24 from Text import class Text(ltrim,indexOf,concat), instance Text String
26 from StdMisc import undef
31 derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either, IRCMessage, IRCUser, IRCNumReply
33 Start = jon "\n" $ map printToString
34 [ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n"
35 , parseIRCMessage ":clooglebot!~cloogle QUIT\r\n"
36 , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
37 , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
38 , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n"
39 , parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n"
40 , parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n"
43 (<+) infixr 5 :: a b -> String | toString a & toString b
44 (<+) a b = toString a +++ toString b
46 parseIRCMessage :: String -> Either [Error] IRCMessage
47 parseIRCMessage s = case runParser parsePrefix (fromString s) of
48 ([(prefix, rest):_], _)
49 = case parse parseReply rest of
50 Left e = case parseCmd rest of
51 Left e2 = Left $ e2 ++ e
52 Right cmd = Right {IRCMessage | irc_prefix=prefix, irc_command=Right cmd}
53 Right repl = Right {IRCMessage | irc_prefix=prefix, irc_command=Left repl}
54 (_, es) = Left ["couldn't parse prefix":es]
56 parsePrefix :: Parser Char (Maybe (Either IRCUser String))
57 parsePrefix = optional (pToken ':' >>| parseEither parseUser parseHost) <* pToken ' '
59 generic gIRCParse a :: Parser String a
60 gIRCParse{|String|} = pSatisfy (const True)
61 gIRCParse{|Int|} = toInt <$> pSatisfy (const True)
62 gIRCParse{|EITHER|} p b = LEFT <$> p <|> RIGHT <$> b
63 gIRCParse{|PAIR|} p b = liftM2 PAIR p b
64 gIRCParse{|UNIT|} = pFail
65 gIRCParse{|OBJECT|} p = OBJECT <$> p
66 gIRCParse{|CONS of d|} p = CONS <$> (pToken d.gcd_name >>| p)
67 gIRCParse{|Maybe|} p = optional p
68 gIRCParse{|(,)|} p s = liftM2 tuple p s
69 gIRCParse{|[]|} p = pMany p
70 gIRCParse{|(->)|} p b = undef
72 derive gIRCParse IRCCommand
74 parseCmd :: [Char] -> Either [Error] IRCCommand
76 = parse gIRCParse{|*|} $ argfun $ 'Text'.split " " $ toString cs
77 //= parse cmdParser $ argfun $ 'Text'.split " " $ toString cs
79 argfun :: [String] -> [String]
83 | x.[0] == ':' = [jon " " $ [x:map 'Text'.rtrim xs]]
84 | otherwise = [x:argfun xs]
86 p = pSatisfy (const True)
87 lst = fmap $ 'Text'.split ","
91 nn p f = pToken p >>| f
93 cmdParser :: Parser String IRCCommand
95 (nn "ADMIN" $ fmap ADMIN opt)
96 <|> (nn "AWAY" $ fmap AWAY p)
97 <|> (nn "CONNECT" $ liftM2 CONNECT p (optional $ liftM2 tuple pInt opt))
98 <|> (nn "DIE" $ pure DIE)
99 <|> (nn "ERROR" $ fmap ERROR p)
100 <|> (nn "INFO" $ fmap INFO opt)
101 <|> (nn "INVITE" $ liftM2 INVITE p p)
102 <|> (nn "ISON" $ fmap ISON $ pMany p)
103 // <|> (nn "JOIN" $ fmap JOIN $ lst p >>= \ch->lst p >>= \ks->pure (zip2 ch (ks ++ repeat Nothing)))
104 <|> (nn "KICK" $ liftM3 KICK p p opt)
105 <|> (nn "KILL" $ liftM2 KILL p p)
106 <|> (nn "LINKS" $ fmap LINKS $ optional $ liftM2 tuple opt p)
107 <|> (nn "LIST" $ fmap LIST $ optional $ liftM2 tuple ('Text'.split "," <$> p) opt)
108 <|> (nn "LUSERS" $ fmap LUSERS $ optional $ liftM2 tuple p opt)
109 <|> (nn "MODE" $ liftM5 MODE p p opt opt opt)
110 <|> (nn "MOTD" $ fmap MOTD $ opt)
111 <|> (nn "NAMES" $ fmap NAMES $ lst p)
112 <|> (nn "NICK" $ fmap NAMES $ lst p)
113 //"NICK" = String (Maybe String)
114 //"NJOIN" = command0 NJOIN args
115 //"NOTICE" = String String
116 //"OPER" = String String
119 //"PING" = String (Maybe String)
120 //"PONG" = String (Maybe String)
121 //"PRIVMSG" = [String] String
122 // "QUIT" = case args of
123 // [_,_:_] = Left $ "QUIT has too many arguments"
124 // x = Right $ QUIT $ listToMaybe x
125 // "REHASH" = command0 REHASH args
126 // "RESTART" = command0 REHASH args
127 // "SERVER" = command0 REHASH args
128 //"SERVICE" = String String String String
129 //"SERVLIST" = (Maybe (String, Maybe String))
130 //"SQUERY" = String String
131 // "SQUIRT" = command0 REHASH args
132 //"SQUIT" = String String
133 //"STATS" = (Maybe (String, Maybe String))
134 //"SUMMON" = String (Maybe (String, Maybe String))
135 //"TIME" = (Maybe String)
136 //"TOPIC" = String (Maybe String)
137 //"TRACE" = (Maybe String)
138 //"USER" = String String String
139 //"USERHOST" = [String]
140 //"USERS" = (Maybe String)
141 //"VERSION" = (Maybe String)
143 //"WHO" = (Maybe String)
144 //"WHOIS" = (Maybe String) [String]
145 //"WHOWAS" = (Maybe String) [String]
147 parseReply :: Parser Char IRCNumReply
148 parseReply = (toString <$> pSome pDigit)
150 >>= \recipient->spaceParser >>| (toString <$> pSome (pNoneOf illegal))
151 >>= \msg->pure {IRCNumReply|irc_reply=fs rep,irc_recipient=recipient,irc_message=msg}
153 fs :: String -> IRCReplies
154 fs s = fromInt $ toInt s
156 spaceParser :: Parser Char [Char]
157 spaceParser = pMany $ pToken ' '
159 parseServer :: Parser Char String
162 parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
163 parseEither p q = Left <$> p <|> Right <$> q
165 parseUser :: Parser Char IRCUser
166 parseUser = parseNick
167 >>= \nick->optional (pToken '!' >>| parseUsr)
168 >>= \muser->optional (pToken '@' >>| parseHost)
169 >>= \mhost->pure {IRCUser | irc_nick=nick, irc_user=muser, irc_host=mhost}
171 parseUsr :: Parser Char String
172 parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])
174 parseNick :: Parser Char String
175 parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial)
176 >>= \cs->pure (toString [c:cs])
178 pSpecial :: Parser Char Char
179 pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
181 parseHost :: Parser Char String
182 parseHost = jon "." <$> pSepBy parseName (pToken '.')
184 parseName :: Parser Char String
185 parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-'])
187 instance toString IRCNumReply where
188 toString m = toInt m.irc_reply <+ " " <+ m.irc_recipient <+ " " <+ formatMSG m.irc_message
189 instance toString IRCMessage where
190 toString m = maybe "" (\s->either ((<+) ":") id s <+ " ") m.irc_prefix
191 <+ either toString toString m.irc_command
193 instance toString IRCUser where
194 toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
195 <+ maybe "" ((<+) "@") m.irc_host
200 pMiddle :: Parser Char String
201 pMiddle = fmap toString $
202 spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal])
204 pTrailing :: Parser Char String
205 pTrailing = fmap toString $
206 spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal)
208 pParam :: Parser Char String
209 pParam = pMiddle <|> pTrailing
211 pNoneOf :: [a] -> Parser a a | Eq a
212 pNoneOf l = pSatisfy (not o flip isMember l)
214 pNotSatisfy :: (a -> Bool) -> Parser a a | Eq a
215 pNotSatisfy f = pSatisfy (not o f)
217 pInt :: Parser Char Int
218 pInt = toInt o toString <$> (spaceParser >>| pSome pDigit)
221 illegal = ['\x00','\r','\n']
223 instance toString IRCCommand where
224 toString r = jon " " (print r) +++ "\r\n"
226 print :: IRCCommand -> [String]
228 ADMIN mm = ["ADMIN":maybeToList mm]
230 //CONNECT String (Maybe (Int, Maybe String))
233 //INFO (Maybe String)
234 //INVITE String String
236 JOIN chs = ["JOIN",if (isEmpty chs) "0"
237 (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs])]
238 //KICK String String (Maybe String)
240 //LINKS (Maybe (Maybe String, String))
241 //LIST (Maybe ([String], Maybe String))
242 //LUSERS (Maybe (String, Maybe String))
243 //MODE String String (Maybe String) (Maybe String) (Maybe String)
244 //MOTD (Maybe String)
246 NICK n ms = ["NICK", n]
248 //NOTICE String String
252 PING a mb = ["PING",a:maybeToList mb]
253 PONG a mb = ["PONG",a:maybeToList mb]
254 PRIVMSG dest msg = ["PRIVMSG",jon "," dest,formatMSG msg]
255 QUIT msg = ["QUIT":maybeToList msg]
259 //SERVICE String String String String
260 //SERVLIST (Maybe (String, Maybe String))
261 //SQUERY String String
263 //SQUIT String String
264 //STATS (Maybe (String, Maybe String))
265 //SUMMON String (Maybe (String, Maybe String))
266 //TIME (Maybe String)
267 //TOPIC String (Maybe String)
268 //TRACE (Maybe String)
269 USER login mode rn = ["USER", login, mode, "*", ":"+++rn]
271 //USERS (Maybe String)
272 //VERSION (Maybe String)
275 //WHOIS (Maybe String) [String]
276 //WHOWAS (Maybe String) [String]
277 _ = [printToString r]
279 formatMSG :: String -> String
280 formatMSG s = if (indexOf " " s > 0 || indexOf " " s > 0) (":" +++ s) s
283 instance toString IRCReplies where toString r = printToString r
284 instance toString IRCErrors where toString r = printToString r
286 instance fromInt IRCReplies where
287 fromInt r = case r of
294 201 = RPL_TRACECONNECTING
295 202 = RPL_TRACEHANDSHAKE
296 203 = RPL_TRACEUNKNOWN
297 204 = RPL_TRACEOPERATOR
299 206 = RPL_TRACESERVER
300 207 = RPL_TRACESERVICE
301 208 = RPL_TRACENEWTYPE
303 210 = RPL_TRACERECONNECT
304 211 = RPL_STATSLINKINFO
305 212 = RPL_STATSCOMMANDS
309 235 = RPL_SERVLISTEND
310 242 = RPL_STATSUPTIME
312 251 = RPL_LUSERCLIENT
314 253 = RPL_LUSERUNKNOWN
315 254 = RPL_LUSERCHANNELS
330 312 = RPL_WHOISSERVER
331 313 = RPL_WHOISOPERATOR
336 319 = RPL_WHOISCHANNELS
340 324 = RPL_CHANNELMODEIS
347 347 = RPL_ENDOFINVITELIST
349 349 = RPL_ENDOFEXCEPTLIST
357 368 = RPL_ENDOFBANLIST
358 369 = RPL_ENDOFWHOWAS
366 383 = RPL_YOURESERVICE
374 instance toInt IRCReplies where
382 RPL_TRACECONNECTING = 201
383 RPL_TRACEHANDSHAKE = 202
384 RPL_TRACEUNKNOWN = 203
385 RPL_TRACEOPERATOR = 204
387 RPL_TRACESERVER = 206
388 RPL_TRACESERVICE = 207
389 RPL_TRACENEWTYPE = 208
391 RPL_TRACERECONNECT = 210
392 RPL_STATSLINKINFO = 211
393 RPL_STATSCOMMANDS = 212
397 RPL_SERVLISTEND = 234
398 RPL_STATSUPTIME = 242
400 RPL_LUSERCLIENT = 251
402 RPL_LUSERUNKNOWN = 253
403 RPL_LUSERCHANNELS = 254
418 RPL_WHOISSERVER = 312
419 RPL_WHOISOPERATOR = 313
424 RPL_WHOISCHANNELS = 319
428 RPL_CHANNELMODEIS = 324
435 RPL_ENDOFINVITELIST = 347
437 RPL_ENDOFEXCEPTLIST = 349
445 RPL_ENDOFBANLIST = 367
446 RPL_ENDOFWHOWAS = 369
454 RPL_YOURESERVICE = 383
461 instance fromInt IRCErrors where
462 fromInt r = case r of
464 402 = ERR_NOSUCHSERVER
465 403 = ERR_NOSUCHCHANNEL
466 404 = ERR_CANNOTSENDTOCHAN
467 405 = ERR_TOOMANYCHANNELS
468 406 = ERR_WASNOSUCHNICK
469 407 = ERR_TOOMANYTARGETS
470 408 = ERR_NOSUCHSERVICE
472 411 = ERR_NORECIPIENT
473 412 = ERR_NOTEXTTOSEND
475 414 = ERR_WILDTOPLEVEL
477 421 = ERR_UNKNOWNCOMMAND
479 423 = ERR_NOADMININFO
481 431 = ERR_NONICKNAMEGIVEN
482 432 = ERR_ERRONEUSNICKNAME
483 433 = ERR_NICKNAMEINUSE
484 436 = ERR_NICKCOLLISION
485 437 = ERR_UNAVAILRESOURCE
486 441 = ERR_USERNOTINCHANNEL
487 442 = ERR_NOTONCHANNEL
488 443 = ERR_USERONCHANNEL
490 445 = ERR_SUMMONDISABLED
491 446 = ERR_USERSDISABLED
492 451 = ERR_NOTREGISTERED
493 461 = ERR_NEEDMOREPARAMS
494 462 = ERR_ALREADYREGISTRED
495 463 = ERR_NOPERMFORHOST
496 464 = ERR_PASSWDMISMATCH
497 465 = ERR_YOUREBANNEDCREEP
498 466 = ERR_YOUWILLBEBANNED
500 471 = ERR_CHANNELISFULL
501 472 = ERR_UNKNOWNMODE
502 473 = ERR_INVITEONLYCHAN
503 474 = ERR_BANNEDFROMCHAN
504 475 = ERR_BADCHANNELKEY
505 476 = ERR_BADCHANMASK
506 477 = ERR_NOCHANMODES
507 478 = ERR_BANLISTFULL
508 481 = ERR_NOPRIVILEGES
509 482 = ERR_CHANOPRIVSNEEDED
510 483 = ERR_CANTKILLSERVER
512 485 = ERR_UNIQOPPRIVSNEEDED
514 501 = ERR_UMODEUNKNOWNFLAG
515 502 = ERR_USERSDONTMATCH
517 instance toInt IRCErrors where
520 ERR_NOSUCHSERVER = 402
521 ERR_NOSUCHCHANNEL = 403
522 ERR_CANNOTSENDTOCHAN = 404
523 ERR_TOOMANYCHANNELS = 405
524 ERR_WASNOSUCHNICK = 406
525 ERR_TOOMANYTARGETS = 407
526 ERR_NOSUCHSERVICE = 408
528 ERR_NORECIPIENT = 411
529 ERR_NOTEXTTOSEND = 412
531 ERR_WILDTOPLEVEL = 414
533 ERR_UNKNOWNCOMMAND = 421
535 ERR_NOADMININFO = 423
537 ERR_NONICKNAMEGIVEN = 431
538 ERR_ERRONEUSNICKNAME = 432
539 ERR_NICKNAMEINUSE = 433
540 ERR_NICKCOLLISION = 436
541 ERR_UNAVAILRESOURCE = 437
542 ERR_USERNOTINCHANNEL = 441
543 ERR_NOTONCHANNEL = 442
544 ERR_USERONCHANNEL = 443
546 ERR_SUMMONDISABLED = 445
547 ERR_USERSDISABLED = 446
548 ERR_NOTREGISTERED = 451
549 ERR_NEEDMOREPARAMS = 461
550 ERR_ALREADYREGISTRED = 462
551 ERR_NOPERMFORHOST = 463
552 ERR_PASSWDMISMATCH = 464
553 ERR_YOUREBANNEDCREEP = 465
554 ERR_YOUWILLBEBANNED = 466
556 ERR_CHANNELISFULL = 471
557 ERR_UNKNOWNMODE = 472
558 ERR_INVITEONLYCHAN = 473
559 ERR_BANNEDFROMCHAN = 474
560 ERR_BADCHANNELKEY = 475
561 ERR_BADCHANMASK = 476
562 ERR_NOCHANMODES = 477
563 ERR_BANLISTFULL = 478
564 ERR_NOPRIVILEGES = 481
565 ERR_CHANOPRIVSNEEDED = 482
566 ERR_CANTKILLSERVER = 483
568 ERR_UNIQOPPRIVSNEEDED = 485
570 ERR_UMODEUNKNOWNFLAG = 501
571 ERR_USERSDONTMATCH = 502