X-Git-Url: https://git.martlubbers.net/?p=cloogle-irc.git;a=blobdiff_plain;f=IRC.icl;h=48a58008307f5bc304065f77b399b31f336efcf1;hp=f9d45831693855338c4a17eb99c5bf0758579b79;hb=38119fcb7be8437bc535665f20af8b641ee67e64;hpb=bac25515f111115ec1cd3fd44d9cf857c23e340f diff --git a/IRC.icl b/IRC.icl index f9d4583..48a5800 100644 --- a/IRC.icl +++ b/IRC.icl @@ -1,311 +1,145 @@ implementation module IRC -import StdGeneric -import StdList -import StdTuple -import GenPrint -import GenBimap -import StdOverloaded -import Data.Maybe -import Data.Either -import StdFunc -import StdString -import StdChar -import StdBool +import StdList, StdTuple, StdOverloaded, StdFunc, StdString, StdChar, StdBool import _SystemArray -import Text.Parsers.Simple.Core -import Text.Parsers.Simple.Chars -import Data.Tuple -import Control.Monad +import GenPrint +import GenIRC + import Control.Applicative -from Data.Functor import <$> +import Control.Monad +import Data.Either +import Data.Maybe +import Data.Tuple +import Text.Parsers.Simple.Chars +import Text.Parsers.Simple.Core +import StdDebug + +from Data.Functor import <$> from Data.Func import $ -from Text import class Text(ltrim,indexOf,concat), instance Text String +from StdMisc import undef, abort +from Text import class Text(lpad,trim,rtrim,split,indexOf,concat), + instance Text String import qualified Text -from StdMisc import undef -import StdDebug jon :== 'Text'.join -derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either, IRCMessage, IRCUser, IRCNumReply +derive gPrint IRCErrors, IRCReplies, Maybe, Either, IRCUser, IRCNumReply -Start = jon "\n" $ map printToString - [ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n" - , parseIRCMessage ":clooglebot!~cloogle QUIT\r\n" - , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n" - , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n" - , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n" - , parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n" - , parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n" - ] - -(<+) infixr 5 :: a b -> String | toString a & toString b -(<+) a b = toString a +++ toString b +Start = (map (fmap toString) msgs, msgs) +where + msgs = + [ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n" + , parseIRCMessage ":clooglebot!~cloogle QUIT\r\n" + , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n" + , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n" + , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n" + , parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n" + , parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n" + , parseIRCMessage ":cherryh.freenode.net JOIN #cha,#ch-b #twilight\r\n" + , parseIRCMessage ":cherryh.freenode.net ISON a b c d e f :g h\r\n" + , parseIRCMessage ":wilhelm.freenode.net 001 clooglebot :Welcome to the freenode Internet Relay Chat Network clooglebot\r\n" + , parseIRCMessage "PING :orwell.freenode.net\r\n" + , parseIRCMessage ":ChanServ!ChanServ@services. MODE #cloogle +o frobnicator\r\n" + , parseIRCMessage ":qbot_v01!~qbot@ip-213-124-170-20.ip.prioritytelecom.net PRIVMSG ##chinees :[link] Cloogle - https://cloogle.org" + ] parseIRCMessage :: String -> Either [Error] IRCMessage parseIRCMessage s = case runParser parsePrefix (fromString s) of + // Prefix is parsed ([(prefix, rest):_], _) + //Try parsing a numeric reply = case parse parseReply rest of + //Try a normal command Left e = case parseCmd rest of - Left e2 = Left $ e2 ++ e + Left e2 = Left [e2:e] Right cmd = Right {IRCMessage | irc_prefix=prefix, irc_command=Right cmd} Right repl = Right {IRCMessage | irc_prefix=prefix, irc_command=Left repl} - (_, es) = Left ["couldn't parse prefix":es] + // Error parsing prefix + (_, es) = Left ["Error parsing prefix"] +//Prefix parsePrefix :: Parser Char (Maybe (Either IRCUser String)) -parsePrefix = optional (pToken ':' >>| parseEither parseUser parseHost) <* pToken ' ' - -generic gIRCParse a :: [String] -> (Either [Error] a, [String]) -gIRCParse{|UNIT|} a = (Right UNIT, a) -gIRCParse{|String|} [a:as] = (Right a, as) -gIRCParse{|String|} [] = (Left ["Expected a string"], []) -gIRCParse{|Int|} [a:as] = (Right $ toInt a, as) -gIRCParse{|Int|} [] = (Left ["Expected an integer"], []) -gIRCParse{|EITHER|} lp rp as = case lp as of - (Right a, rest) = (Right $ LEFT a, rest) - (Left e1, rest) = case rp as of - (Right a, rest) = (Right $ RIGHT a, rest) - (Left e2, rest) = (Left $ e1 ++ e2, []) -gIRCParse{|OBJECT|} p as = case p as of - (Right e, rest) = (Right $ OBJECT e, rest) - (Left e, rest) = (Left e, []) -gIRCParse{|CONS of d|} p [] = (Left ["Expected a cmd constructor: " +++ d.gcd_name], []) -gIRCParse{|CONS of d|} p [a:as] -| a <> d.gcd_name = (Left ["Wrong constructor. expected: " +++ d.gcd_name +++ ", got: " +++ a], []) -= case p as of - (Right a, rest) = (Right $ CONS a, rest) - (Left e, rest) = (Left e, []) -gIRCParse{|PAIR|} pl pr as = case pl as of - (Right a1, rest) = case pr rest of - (Right a2, rest) = (Right $ PAIR a1 a2, rest) - (Left e, rest) = (Left e, []) - (Left e, rest) = (Left e, []) -gIRCParse{|[]|} pl as = plist pl as +parsePrefix + = optional (pToken ':' >>| parseEither parseUser parseHost <* pToken ' ') where - plist pl as = case pl as of - (Right e, rest) = case plist pl rest of - (Right es, rest) = (Right [e:es], rest) - (Left e, rest) = (Left e, []) - (Left e, rest) = (Right [], as) -gIRCParse{|Maybe|} pm as = case pm as of - (Right a, rest) = (Right $ Just a, rest) - (Left e, rest) = (Right Nothing, as) - -derive gIRCParse (,), (,,), IRCCommand - -parseCmd :: [Char] -> Either [Error] IRCCommand -parseCmd cs = fst $ gIRCParse{|*|} $ argfun $ 'Text'.split " " $ toString cs -//= parse cmdParser $ argfun $ 'Text'.split " " $ toString cs + parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c) + parseEither p q = Left <$> p <|> Right <$> q + + parseUser :: Parser Char IRCUser + parseUser = parseNick + >>= \nick->optional (pToken '!' >>| parseUsr) + >>= \muser->optional (pToken '@' >>| parseHost) + >>= \mhost->pure {IRCUser + | irc_nick=nick, irc_user=muser, irc_host=mhost} + + parseUsr :: Parser Char String + parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal]) + + parseNick :: Parser Char String + parseNick = pAlpha + >>= \c ->pMany (pAlpha <|> pDigit <|> pOneOf (fromString "_-[]\\`^{}")) + >>= \cs->pure (toString [c:cs]) + + parseHost :: Parser Char String + parseHost = jon "." <$> (pSepBy parseName (pToken '.')) + >>= \s->optional (pToken '.') >>= pure o maybe s (\p->s+++toString s) + where + parseName :: Parser Char String + parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-', '/']) + +//Parse Cmd +parseCmd :: [Char] -> Either Error IRCCommand +parseCmd cs = fst $ gIRCParse{|*|} $ argfun $ split " " $ toString cs where argfun :: [String] -> [String] argfun [] = [] argfun [x:xs] - # x = 'Text'.trim x - | x.[0] == ':' = [jon " " $ [x:map 'Text'.rtrim xs]] + # x = trim x + | x.[0] == ':' = [jon " " $ [x % (1, size x):map rtrim xs]] | otherwise = [x:argfun xs] - p = pSatisfy (const True) - lst = fmap $ 'Text'.split "," - opt = optional p - pInt = toInt <$> p - - nn p f = pToken p >>| f - - cmdParser :: Parser String IRCCommand - cmdParser = - (nn "ADMIN" $ fmap ADMIN opt) - <|> (nn "AWAY" $ fmap AWAY p) - <|> (nn "CONNECT" $ liftM2 CONNECT p (optional $ liftM2 tuple pInt opt)) - <|> (nn "DIE" $ pure DIE) - <|> (nn "ERROR" $ fmap ERROR p) - <|> (nn "INFO" $ fmap INFO opt) - <|> (nn "INVITE" $ liftM2 INVITE p p) - <|> (nn "ISON" $ fmap ISON $ pMany p) -// <|> (nn "JOIN" $ fmap JOIN $ lst p >>= \ch->lst p >>= \ks->pure (zip2 ch (ks ++ repeat Nothing))) - <|> (nn "KICK" $ liftM3 KICK p p opt) - <|> (nn "KILL" $ liftM2 KILL p p) - <|> (nn "LINKS" $ fmap LINKS $ optional $ liftM2 tuple opt p) - <|> (nn "LIST" $ fmap LIST $ optional $ liftM2 tuple ('Text'.split "," <$> p) opt) - <|> (nn "LUSERS" $ fmap LUSERS $ optional $ liftM2 tuple p opt) - <|> (nn "MODE" $ liftM5 MODE p p opt opt opt) - <|> (nn "MOTD" $ fmap MOTD $ opt) - <|> (nn "NAMES" $ fmap NAMES $ lst p) - <|> (nn "NICK" $ fmap NAMES $ lst p) - //"NICK" = String (Maybe String) - //"NJOIN" = command0 NJOIN args - //"NOTICE" = String String - //"OPER" = String String - //"PART" = [String] - //"PASS" = String - //"PING" = String (Maybe String) - //"PONG" = String (Maybe String) - //"PRIVMSG" = [String] String -// "QUIT" = case args of -// [_,_:_] = Left $ "QUIT has too many arguments" -// x = Right $ QUIT $ listToMaybe x -// "REHASH" = command0 REHASH args -// "RESTART" = command0 REHASH args -// "SERVER" = command0 REHASH args - //"SERVICE" = String String String String - //"SERVLIST" = (Maybe (String, Maybe String)) - //"SQUERY" = String String -// "SQUIRT" = command0 REHASH args - //"SQUIT" = String String - //"STATS" = (Maybe (String, Maybe String)) - //"SUMMON" = String (Maybe (String, Maybe String)) - //"TIME" = (Maybe String) - //"TOPIC" = String (Maybe String) - //"TRACE" = (Maybe String) - //"USER" = String String String - //"USERHOST" = [String] - //"USERS" = (Maybe String) - //"VERSION" = (Maybe String) - //"WALLOPS" = String - //"WHO" = (Maybe String) - //"WHOIS" = (Maybe String) [String] - //"WHOWAS" = (Maybe String) [String] - +//Reply parseReply :: Parser Char IRCNumReply -parseReply = (toString <$> pSome pDigit) - >>= \rep->pMiddle - >>= \recipient->spaceParser >>| (toString <$> pSome (pNoneOf illegal)) - >>= \msg->pure {IRCNumReply|irc_reply=fs rep,irc_recipient=recipient,irc_message=msg} +parseReply = spaceParser + >>| (pMany (pToken '0') >>| pSome pDigit <* spaceParser) + >>= \rep->(toString <$> pSome (pNoneOf [' ':illegal]) <* spaceParser) + >>= \rec->(toString <$> pSome (pNoneOf illegal)) + >>= \msg->pure {IRCNumReply + | irc_reply = fromInt $ toInt $ toString rep + , irc_recipient = rec + , irc_message = msg % (if (msg.[0] == ':') 1 0, size msg) + } + <* pToken '\r' <* pToken '\n' where - fs :: String -> IRCReplies - fs s = fromInt $ toInt s - -spaceParser :: Parser Char [Char] -spaceParser = pMany $ pToken ' ' + spaceParser :: Parser Char [Char] + spaceParser = pMany $ pToken ' ' -parseServer :: Parser Char String -parseServer = pFail - -parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c) -parseEither p q = Left <$> p <|> Right <$> q - -parseUser :: Parser Char IRCUser -parseUser = parseNick - >>= \nick->optional (pToken '!' >>| parseUsr) - >>= \muser->optional (pToken '@' >>| parseHost) - >>= \mhost->pure {IRCUser | irc_nick=nick, irc_user=muser, irc_host=mhost} - -parseUsr :: Parser Char String -parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal]) - -parseNick :: Parser Char String -parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial) - >>= \cs->pure (toString [c:cs]) - -pSpecial :: Parser Char Char -pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}'] +//Common parsers +pNoneOf :: [a] -> Parser a a | Eq a +pNoneOf l = pSatisfy (not o flip isMember l) -parseHost :: Parser Char String -parseHost = jon "." <$> pSepBy parseName (pToken '.') - where - parseName :: Parser Char String - parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-']) +illegal :: [Char] +illegal = ['\x00','\r','\n'] instance toString IRCNumReply where - toString m = toInt m.irc_reply <+ " " <+ m.irc_recipient <+ " " <+ formatMSG m.irc_message + toString m = lpad (toString $ toInt m.irc_reply) 3 '0' <+ " " <+ + m.irc_recipient <+ " " <+ concat (gIRCPrint{|*|} m.irc_message) instance toString IRCMessage where toString m = maybe "" (\s->either ((<+) ":") id s <+ " ") m.irc_prefix <+ either toString toString m.irc_command - instance toString IRCUser where toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user <+ maybe "" ((<+) "@") m.irc_host - -cons :: a [a] -> [a] -cons a as = [a:as] - -pMiddle :: Parser Char String -pMiddle = fmap toString $ - spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal]) - -pTrailing :: Parser Char String -pTrailing = fmap toString $ - spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal) - -pParam :: Parser Char String -pParam = pMiddle <|> pTrailing - -pNoneOf :: [a] -> Parser a a | Eq a -pNoneOf l = pSatisfy (not o flip isMember l) - -pNotSatisfy :: (a -> Bool) -> Parser a a | Eq a -pNotSatisfy f = pSatisfy (not o f) - -pInt :: Parser Char Int -pInt = toInt o toString <$> (spaceParser >>| pSome pDigit) - -illegal :: [Char] -illegal = ['\x00','\r','\n'] - instance toString IRCCommand where - toString r = jon " " (print r) +++ "\r\n" - -print :: IRCCommand -> [String] -print r = case r of - ADMIN mm = ["ADMIN":maybeToList mm] - AWAY m = ["AWAY",m] - //CONNECT String (Maybe (Int, Maybe String)) - //DIE - //ERROR String - //INFO (Maybe String) - //INVITE String String - //ISON [String] - JOIN chs = ["JOIN",if (isEmpty chs) "0" - (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs])] - //KICK String String (Maybe String) - //KILL String String - //LINKS (Maybe (Maybe String, String)) - //LIST (Maybe ([String], Maybe String)) - //LUSERS (Maybe (String, Maybe String)) - //MODE String String (Maybe String) (Maybe String) (Maybe String) - //MOTD (Maybe String) - //NAMES [String] - NICK n ms = ["NICK", n] - //NJOIN - //NOTICE String String - //OPER String String - //PART [String] - //PASS String - PING a mb = ["PING",a:maybeToList mb] - PONG a mb = ["PONG",a:maybeToList mb] - PRIVMSG dest msg = ["PRIVMSG",jon "," dest,formatMSG msg] - QUIT msg = ["QUIT":maybeToList msg] - //REHASH - //RESTART - //SERVER - //SERVICE String String String String - //SERVLIST (Maybe (String, Maybe String)) - //SQUERY String String - //SQUIRT - //SQUIT String String - //STATS (Maybe (String, Maybe String)) - //SUMMON String (Maybe (String, Maybe String)) - //TIME (Maybe String) - //TOPIC String (Maybe String) - //TRACE (Maybe String) - USER login mode rn = ["USER", login, mode, "*", ":"+++rn] - //USERHOST [String] - //USERS (Maybe String) - //VERSION (Maybe String) - //WALLOPS String - //WHO (Maybe String) - //WHOIS (Maybe String) [String] - //WHOWAS (Maybe String) [String] - _ = [printToString r] - -formatMSG :: String -> String -formatMSG s = if (indexOf " " s > 0 || indexOf " " s > 0) (":" +++ s) s - - + toString m = jon " " (gIRCPrint{|*|} m) +++ "\r\n" instance toString IRCReplies where toString r = printToString r instance toString IRCErrors where toString r = printToString r +(<+) infixr 5 :: a b -> String | toString a & toString b +(<+) a b = toString a +++ toString b + instance fromInt IRCReplies where fromInt r = case r of 1 = RPL_WELCOME @@ -392,7 +226,7 @@ instance fromInt IRCReplies where 393 = RPL_USERS 394 = RPL_ENDOFUSERS 395 = RPL_NOUSERS - _ = undef + _ = RPL_UNKNOWN instance toInt IRCReplies where toInt r = case r of @@ -480,6 +314,7 @@ instance toInt IRCReplies where RPL_USERS = 393 RPL_ENDOFUSERS = 394 RPL_NOUSERS = 395 + RPL_UNKNOWN = 998 instance fromInt IRCErrors where fromInt r = case r of @@ -536,6 +371,7 @@ instance fromInt IRCErrors where 491 = ERR_NOOPERHOST 501 = ERR_UMODEUNKNOWNFLAG 502 = ERR_USERSDONTMATCH + _ = ERR_UNKNOWN instance toInt IRCErrors where toInt r = case r of @@ -592,3 +428,4 @@ instance toInt IRCErrors where ERR_NOOPERHOST = 491 ERR_UMODEUNKNOWNFLAG = 501 ERR_USERSDONTMATCH = 502 + ERR_UNKNOWN = 999