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)
, irc_host :: Maybe String
}
+parseIRCMessage :: (String -> Either [Error] IRCMessage)
+
instance toString IRCCommand, IRCReplies, IRCErrors, IRCMessage, IRCUser
instance fromInt IRCReplies, IRCErrors
instance toInt IRCReplies, IRCErrors
import StdFunc
import StdString
import StdChar
+import StdBool
import Text.Parsers.Simple.Core
import Text.Parsers.Simple.Chars
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
//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
pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
parseHost :: Parser Char String
-parseHost = parseName
+parseHost = pToken ':' >>| parseName
>>= \nm->pMany (pToken '.' >>| parseName)
>>= \nms->pure (concat [nm:nms])
where
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
<|> 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
//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
//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))
//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
//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)
//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
--- /dev/null
+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)
--- /dev/null
+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)
| 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]
"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"]]
repositories / cloogle-irc.git / commitdiff