From 3134ab7e61bcbc84560b4a5d613a92b1a48362c2 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Sun, 12 Mar 2017 20:31:32 +0100 Subject: [PATCH] extended parsing and added bot interface, note that it does not work... --- IRC.dcl | 4 +++ IRC.icl | 43 ++++++++++++++++---------- IRCBot.dcl | 27 ++++++++++++++++ IRCBot.icl | 77 +++++++++++++++++++++++++++++++++++++++++++++ cloogle.icl | 89 ++++++++++++++++++----------------------------------- 5 files changed, 164 insertions(+), 76 deletions(-) create mode 100644 IRCBot.dcl create mode 100644 IRCBot.icl diff --git a/IRC.dcl b/IRC.dcl index 0fffb7e..ae14b8f 100644 --- a/IRC.dcl +++ b/IRC.dcl @@ -1,8 +1,10 @@ definition module IRC +import IRCBot from Data.Maybe import :: Maybe from Data.Either import :: Either from StdOverloaded import class fromInt, class toInt, class toString, class fromString +from Text.Parsers.Simple.Core import :: Error :: IRCMessage = { irc_prefix :: Maybe (Either String IRCUser) @@ -14,6 +16,8 @@ from StdOverloaded import class fromInt, class toInt, class toString, class from , irc_host :: Maybe String } +parseIRCMessage :: (String -> Either [Error] IRCMessage) + instance toString IRCCommand, IRCReplies, IRCErrors, IRCMessage, IRCUser instance fromInt IRCReplies, IRCErrors instance toInt IRCReplies, IRCErrors diff --git a/IRC.icl b/IRC.icl index 389736b..077334a 100644 --- a/IRC.icl +++ b/IRC.icl @@ -8,6 +8,7 @@ import Data.Either import StdFunc import StdString import StdChar +import StdBool import Text.Parsers.Simple.Core import Text.Parsers.Simple.Chars @@ -17,7 +18,7 @@ import Control.Applicative from Data.Functor import <$> from Data.Func import $ -from Text import class Text(concat), instance Text String +from Text import class Text(indexOf,concat), instance Text String import qualified Text from StdMisc import undef @@ -27,7 +28,9 @@ derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n" //Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n" -Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY test with spaces\r\n" +//Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n" +//Start = runParser parseMessage $ fromString ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n" +Start = runParser parseMessage $ fromString ":cherryh.freenode.net QUIT\r\n" (<+) infixr 5 :: a b -> String | toString a & toString b (<+) a b = toString a +++ toString b @@ -67,7 +70,7 @@ pSpecial :: Parser Char Char pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}'] parseHost :: Parser Char String -parseHost = parseName +parseHost = pToken ':' >>| parseName >>= \nm->pMany (pToken '.' >>| parseName) >>= \nms->pure (concat [nm:nms]) where @@ -86,11 +89,11 @@ cons a as = [a:as] pMiddle :: Parser Char String pMiddle = fmap toString $ - spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal) + spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal]) pTrailing :: Parser Char String pTrailing = fmap toString $ - spaceParser >>| liftM2 cons (pNotSatisfy ((==)':')) (pMany $ pNoneOf [' ':illegal]) + spaceParser >>| pToken ':' >>| pMany (pNoneOf illegal) pParam :: Parser Char String pParam = pMiddle <|> pTrailing @@ -151,7 +154,7 @@ parseCommand = <|> pCommand1 "MOTD" (optional pMiddle) MOTD <|> pCommand1 "NAMES" (pSepBy pMiddle pComma) NAMES //NJOIN - //NOTICE String String + <|> pCommand2 "NOTICE" pParam pParam NOTICE //OPER String String //PART [String] //PASS String @@ -182,8 +185,11 @@ parseCommand = //WHOWAS (Maybe String) [String] instance toString IRCCommand where - toString r = flip (+++) "\r\n" case r of - //ADMIN (Maybe String) + toString r = jon " " (print r) +++ "\r\n" + +print :: IRCCommand -> [String] +print r = case r of + ADMIN mm = ["ADMIN":maybeToList mm] //AWAY String //CONNECT String (Maybe (Int, Maybe String)) //DIE @@ -191,8 +197,8 @@ instance toString IRCCommand where //INFO (Maybe String) //INVITE String String //ISON [String] - JOIN chs = "JOIN " +++ (if (isEmpty chs) "0" - (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs])) + 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)) @@ -201,16 +207,16 @@ instance toString IRCCommand where //MODE String String (Maybe String) (Maybe String) (Maybe String) //MOTD (Maybe String) //NAMES [String] - NICK n ms = jon " " ["NICK", n] + NICK n ms = ["NICK", n] //NJOIN //NOTICE String String //OPER String String //PART [String] //PASS String - PING a mb = jon " " ["PING",a:maybeToList mb] - PONG a mb = jon " " ["PONG",a:maybeToList mb] - PRIVMSG dest msg = undef //jon " " ["PRIVMSG", dest, ":"+++msg] - QUIT msg = jon " " ["QUIT":maybeToList msg] + 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 @@ -224,7 +230,7 @@ instance toString IRCCommand where //TIME (Maybe String) //TOPIC String (Maybe String) //TRACE (Maybe String) - USER login mode rn = jon " " ["USER", login, mode, "*", ":"+++rn] + USER login mode rn = ["USER", login, mode, "*", ":"+++rn] //USERHOST [String] //USERS (Maybe String) //VERSION (Maybe String) @@ -232,7 +238,10 @@ instance toString IRCCommand where //WHO (Maybe String) //WHOIS (Maybe String) [String] //WHOWAS (Maybe String) [String] - _ = printToString r + _ = [printToString r] + +formatMSG :: String -> String +formatMSG s = if (indexOf " " s > 0 || indexOf " " s > 0) (":" +++ s) s instance toString IRCReplies where toString r = printToString r diff --git a/IRCBot.dcl b/IRCBot.dcl new file mode 100644 index 0000000..7ecf7ea --- /dev/null +++ b/IRCBot.dcl @@ -0,0 +1,27 @@ +definition module IRCBot + +from IRC import :: IRCMessage +from Data.Maybe import :: Maybe +from Data.Error import :: MaybeErrorString, :: MaybeError + +/* + * Spawn an IRC Bot + * + * param: Hostname and port + * param: Startup commands that are sent initially. For example: + * [NICK "clooglebot" Nothing + * ,USER "cloogle" "0" "Cloogle bot" + * ,JOIN [("#cloogle",Nothing)]] + * param: Shutdown commands. For example + * [QUIT (Just "Bye")] + * param: Processing function + * param: command received by the server + * param: State + * param: World + * return: Maybe a response, the updated state and the updated world + * If the response is nothing the connection is closed + * All items in the list are sent back + * param: World + * return: Maybe the state together with the new world +*/ +bot :: (String, Int) [IRCMessage] [IRCMessage] a (IRCMessage a *World -> (Maybe [IRCMessage], a, *World)) *World -> (MaybeErrorString a, *World) diff --git a/IRCBot.icl b/IRCBot.icl new file mode 100644 index 0000000..9b6b320 --- /dev/null +++ b/IRCBot.icl @@ -0,0 +1,77 @@ +implementation module IRCBot + +from Data.Func import $ +import Data.Either +import Data.Error +import Data.Maybe +import IRC +import TCPIP + +from Text import class Text(join), instance Text String + +import StdList +import StdBool + +TIMEOUT :== Just 1000 + +bot :: (String, Int) [IRCMessage] [IRCMessage] a (IRCMessage a *World -> (Maybe [IRCMessage], a, *World)) *World -> (MaybeErrorString a, *World) +bot (host, port) start end state bot w +//Lookup hostname +# (ip, w) = lookupIPAddress host w +| isNothing ip = (Error $ "DNS lookup for " +++ host +++ " failed", w) +//Connect +# (rpt,chan,w) = connectTCP_MT TIMEOUT (fromJust ip, port) w +| rpt == TR_Expired = (Error $ "Connection to " +++ host +++ " timed out", w) +| rpt == TR_NoSuccess = (Error $ "Could not connect to " +++ host, w) +// Send startup commands +# (merr, chan, w) = send (map toString start) (fromJust chan) w +| isError merr = (Error $ fromError merr, w) +//Start processing function +# (mer, chan, state, w) = process chan state bot w +| isError mer = (Error $ fromError mer, w) +// Send shutdown commands +# (merr, {rChannel,sChannel}, w) = send (map toString end) chan w +| isError merr = (Error $ fromError merr, w) +//Close channels += (Ok state, closeChannel sChannel (closeRChannel rChannel w)) + +import StdDebug,StdMisc +process :: TCP_DuplexChannel a (IRCMessage a *World -> (Maybe [IRCMessage], a, *World)) *World -> (MaybeErrorString (), TCP_DuplexChannel, a, *World) +process chan state bot w +//Receive +# (merr_resp, chan, w) = recv chan w +| isError merr_resp = (Error (fromError merr_resp), chan, state, w) +# (Ok mresp) = merr_resp +| isNothing mresp = process chan state bot w +| not (trace_tn $ "Received: " +++ fromJust mresp) = undef +//Process += case parseIRCMessage (fromJust mresp) of + (Left err) = (Error $ "IRC Parsing error: " +++ join "\n" err, chan, state, w) + (Right msg) + # (mircc, state, w) = bot msg state w + | isNothing mircc = (Ok (), chan, state, w) // Bot asks to quit + //Possible send the commands + # (merr, chan, w) = send (map toString $ fromJust mircc) chan w + | isError merr = (Error $ fromError merr, chan, state, w) + //Recurse + = process chan state bot w + +send :: [String] TCP_DuplexChannel *World -> (MaybeErrorString (), TCP_DuplexChannel, *World) +send [] chan w = (Ok (), chan, w) +send [msg:msgs] {sChannel,rChannel} w +# (_, w) = sleep 250000 w +# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq msg) sChannel w +| rpt <> TR_Success = (Error "Could not send message", {sChannel=sChannel,rChannel=rChannel}, w) += send msgs {sChannel=sChannel,rChannel=rChannel} w + where + sleep :: !Int !*World -> (!Int, *World) + sleep i w = code { + ccall usleep "I:I:A" + } + +recv :: TCP_DuplexChannel *World -> (MaybeErrorString (Maybe String), TCP_DuplexChannel, *World) +recv {sChannel,rChannel} w +# (rpt, resp, rChannel, w) = receive_MT TIMEOUT rChannel w +| rpt == TR_Expired = (Ok Nothing, {sChannel=sChannel,rChannel=rChannel}, w) +| rpt == TR_NoSuccess || isNothing resp = (Error "Timeout recv fail", {sChannel=sChannel,rChannel=rChannel}, w) += (Ok $ Just $ toString $ fromJust resp, {sChannel=sChannel,rChannel=rChannel}, w) diff --git a/cloogle.icl b/cloogle.icl index a7a428e..b130300 100644 --- a/cloogle.icl +++ b/cloogle.icl @@ -164,40 +164,7 @@ cloogle data w | size s > 80 = subString 0 77 s + "..." = s -send :: [String] TCP_DuplexChannel *World -> (TCP_DuplexChannel, *World) -send [] chan w = (chan, w) -send [msg:msgs] {sChannel,rChannel} w -# (_, w) = sleep 250000 w -# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq msg) sChannel w -| rpt <> TR_Success = abort "Could not send request\n" -= send msgs {sChannel=sChannel,rChannel=rChannel} w - where - sleep :: !Int !*World -> (!Int, *World) - sleep i w = code { - ccall usleep "I:I:A" - } - -recv :: TCP_DuplexChannel *World -> (Maybe String, TCP_DuplexChannel, *World) -recv {sChannel,rChannel} w -# (rpt, resp, rChannel, w) = receive_MT TIMEOUT rChannel w -| rpt == TR_Expired = (Nothing, {sChannel=sChannel,rChannel=rChannel}, w) -| rpt == TR_NoSuccess || isNothing resp = abort "Halp?\n" -= (toString <$> resp, {sChannel=sChannel,rChannel=rChannel}, w) - -msg :: (String -> IRCCommand) -msg = PRIVMSG ["#cloogle"] - -process :: *File TCP_DuplexChannel *World -> (*File, TCP_DuplexChannel, *World) -process io chan w -# (mr, chan, w) = recv chan w -| isNothing mr = process io chan w -# resp = fromJust mr -#! io = io <<< ("Received: " +++ resp +++ "\n") -# ind = indexOf KEY resp -| ind >= 0 - # cmd = split " " $ rtrim $ subString (ind + size KEY) (size resp) resp - #! io = io <<< ("Received command: " +++ printToString cmd +++ "\n") - # (w, toSend) = case cmd of +/* ["stop":_] = (w, Nothing) ["ping":xs] = (w, Just [msg $ "pong " +++ join " " xs]) ["query":xs] @@ -217,28 +184,32 @@ process io chan w "short" = Just [msg "short URL - I will give the url to https://cloo.gl shortening service and post back the result"] _ = Just [msg "Unknown command"]) [c:_] = (w, Just [msg $ join " " ["unknown command: " , c, ", type !help to get help"]]) - | isNothing toSend = (io, chan, w) - # (chan, w) = send (map toString $ fromJust toSend) chan w - = process io chan w -| indexOf "PING :" resp >= 0 - # cmd = rtrim $ subString (indexOf "PING :" resp + size "PING :") (size resp) resp - #! io = io <<< (toString $ PONG cmd Nothing) <<< "\n" - # (chan, w) = send [toString $ PONG cmd Nothing] chan w - = process io chan w -= process io chan w - -Start :: *World -> *World -Start w -# (io, w) = stdio w -# (ip, w) = lookupIPAddress SERVER w -| isNothing ip = abort $ "DNS lookup for " +++ SERVER +++ " failed\n" -# (Just ip) = ip -# (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, 6667) w -| rpt == TR_Expired = abort $ "Connection to " +++ SERVER +++ " timed out\n" -| rpt == TR_NoSuccess = abort $ "Could not connect to " +++ SERVER +++ "\n" -# chan = fromJust chan -# (chan, w) = send commands chan w -# (io, chan, w) = process io chan w -# ({sChannel,rChannel}, w) = send [toString $ QUIT Nothing] chan w -# (_, w) = fclose io w -= closeChannel sChannel (closeRChannel rChannel w) +*/ + +Start :: *World -> (MaybeErrorString (), *World) +Start w = bot ("irc.freenode.net", 6667) startup shutdown () process w + where + toPrefix c = {irc_prefix=Nothing,irc_command=c} + startup = map toPrefix + [NICK "clooglebot" Nothing + ,USER "cloogle" "0" "Cloogle bot" + ,JOIN [("#cloogle", Nothing)]] + shutdown = map toPrefix [QUIT (Just "Bye")] + + process :: IRCMessage () *World -> (Maybe [IRCMessage], (), *World) + process im s w = case process` im.irc_command w of + (Nothing, w) = (Nothing, (), w) + (Just cs, w) = (Just $ map toPrefix cs, (), w) + + process` :: IRCCommand *World -> (Maybe [IRCCommand], *World) + process` (PRIVMSG t m) w = (Just $ if (startsWith "!" m) + (map (PRIVMSG t) $ realProcess $ split " " $ subString 1 (size m) m) + [], w) + process` (PING t mt) w = (Just [PONG t mt], w) + process` _ w = (Just [], w) + + realProcess :: [String] -> [String] + realProcess ["help":xs] = + ["type !help cmd for command specific help" + ,"available commands: help"] + realProcess [c:_] = [join " " ["unknown cmd: ", c, ", type !help to get help"]] -- 2.20.1