Commit 3134ab7e authored by Mart Lubbers's avatar Mart Lubbers

extended parsing and added bot interface, note that it does not work...

parent 663ea3d6
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
......
......@@ -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
......
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)
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)
......@@ -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"]]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment