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

diff --git a/IRC.dcl b/IRC.dcl
index 0fffb7e..ae14b8f 100644 (file)
--- a/IRC.dcl
+++ b/IRC.dcl
@@ -1,8 +1,10 @@
 definition module IRC
 
 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 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)
 
 :: 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
        }
 
        , irc_host :: Maybe String
        }
 

+parseIRCMessage :: (String -> Either [Error] IRCMessage)
+

 instance toString IRCCommand, IRCReplies, IRCErrors, IRCMessage, IRCUser
 instance fromInt IRCReplies, IRCErrors
 instance toInt IRCReplies, IRCErrors
 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 (file)
--- a/IRC.icl
+++ b/IRC.icl
@@ -8,6 +8,7 @@ import Data.Either
 import StdFunc
 import StdString
 import StdChar
 import StdFunc
 import StdString
 import StdChar

+import StdBool

 
 import Text.Parsers.Simple.Core
 import Text.Parsers.Simple.Chars
 
 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 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
 
 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 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
 
 (<+) 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
 pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
 
 parseHost :: Parser Char String

-parseHost = parseName
+parseHost = pToken ':' >>| parseName

        >>= \nm->pMany (pToken '.' >>| parseName)
        >>= \nms->pure (concat [nm:nms])
        where
        >>= \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 $
 
 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 $ 
 
 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
 
 pParam :: Parser Char String
 pParam = pMiddle <|> pTrailing


@@ -151,7 +154,7 @@ parseCommand =
        <|> pCommand1 "MOTD" (optional pMiddle) MOTD
        <|> pCommand1 "NAMES" (pSepBy pMiddle pComma) NAMES
        //NJOIN 
        <|> 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
        //OPER String String 
        //PART [String]
        //PASS String


@@ -182,8 +185,11 @@ parseCommand =
        //WHOWAS (Maybe String) [String]
 
 instance toString IRCCommand where
        //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 
        //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]
        //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))
        //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]
        //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
        //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 
        //REHASH 
        //RESTART 
        //SERVER 


@@ -224,7 +230,7 @@ instance toString IRCCommand where
        //TIME (Maybe String)
        //TOPIC String (Maybe String)
        //TRACE (Maybe String)
        //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)
        //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]
        //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
 
 
 instance toString IRCReplies where toString r = printToString r

diff --git a/IRCBot.dcl b/IRCBot.dcl
new file mode 100644 (file)
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 (file)
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 (file)
--- a/cloogle.icl
+++ b/cloogle.icl
@@ -164,40 +164,7 @@ cloogle data w
                | size s > 80 = subString 0 77 s + "..."
                = s
 
                | 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]
                ["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"]])
                        "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"]]