10 from Data.Func import $, mapSt
11 from Text import class Text(..), instance Text String, instance + String
17 import Control.Applicative
18 import qualified Control.Monad as CM
19 import qualified Data.Map as DM
20 from Control.Monad import class Monad, instance Monad Maybe
21 from Text.Encodings.UrlEncoding import urlEncode
32 TIMEOUT :== Just 10000
33 SERVER :== "irc.freenode.net"
35 doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
37 # (ip,w) = lookupIPAddress server_name w
39 = (Error $ "DNS lookup for " + server_name + " failed.", w)
41 # (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
43 = (Error $ "Connection to " + toString ip + " timed out.", w)
45 = (Error $ "Could not connect to " + server_name + ".", w)
46 # (Just {sChannel,rChannel}) = chan
47 # (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq req) sChannel w
49 = (Error $ "Could not send request to " + server_name + ".", w)
50 # (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
52 = (Error $ "Did not receive a reply from " + server_name + ".", w)
53 # resp = 'CM'.join $ parseResponse <$> toString <$> resp
55 # w = closeChannel sChannel (closeRChannel rChannel w)
56 = (Error $ "Server did not respond with HTTP.", w)
57 # (resp,rChannel,w) = receiveRest (fromJust resp) rChannel w
58 # w = closeChannel sChannel (closeRChannel rChannel w)
61 server_name = req.server_name
62 receiveRest resp chan w
63 # cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
66 | size resp.rsp_data >= toInt (fromJust cl)
68 # (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
70 = (Error $ server_name + " hung up during transmission.", chan, w)
71 = receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
76 doRequestL :: HTTPRequest Int *World -> *(MaybeErrorString HTTPResponse, *World)
77 doRequestL req 0 w = (Error "Maximal redirect number exceeded", w)
78 doRequestL req maxRedirects w
79 | not (trace_tn $ toString req) = undef
80 # (er, w) = doRequest req w
81 | isError er = (er, w)
83 | isMember resp.HTTPResponse.rsp_code [301, 302, 303, 307, 308]
84 = case lookup "Location" resp.HTTPResponse.rsp_headers of
85 Nothing = (Error $ "Redirect given but no Location header", w)
86 Just loc = case parseURI loc of
87 Nothing = (Error $ "Redirect URI couldn't be parsed", w)
88 Just uri = doRequestL {req
89 & server_name = maybe loc id uri.uriRegName
90 , server_port = maybe 80 id uri.uriPort
91 , req_path = uri.uriPath
92 , req_query = maybe "" ((+++) "?") uri.uriQuery
96 shorten :: String *World -> (String, *World)
98 # s = if (startsWith "http://" s) s (if (startsWith "https://" s) s ("http://" + s))
99 # data = "type=regular&url="+urlEncode s+"&token=a"
100 # (mer, w) = doRequest
102 & req_method = HTTP_POST
104 , server_name = "cloo.gl"
106 , req_headers = 'DM'.fromList
107 [("Content-Type", "application/x-www-form-urlencoded")
108 ,("Content-Length", toString $ size data)
111 | isError mer = ("request failed: " + fromError mer, w)
115 cloogle :: String *World -> (String, *World)
117 # (mer, w) = doRequestL
119 & req_path = "/api.php"
120 , req_query = "?str=" + urlEncode data
121 , req_headers = 'DM'.fromList [("User-Agent", "cloogle-irc")]
122 , server_name = "cloogle.org"
123 , server_port = 80} 10 w
124 | isError mer = ("request failed: " + fromError mer, w)
126 = case fromJSON $ fromString resp.HTTPResponse.rsp_data of
127 Nothing = ("couldn't parse json", w)
128 Just clr = ("Results for " + data + " -- https://cloogle.org/#" +
129 replaceSubString "+" "%20" (urlEncode data) + "\n" +
130 processResults clr, w)
132 processResults :: Response -> String
134 | resp.return > 127 = "Failed: return code: " + toString resp.return + ", " + resp.msg
135 = join "\n" $ map processResult $ take 3 resp.data
137 processResult :: Result -> String
138 processResult (FunctionResult (br, {func}))
139 = "Function in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ func
140 processResult (TypeResult (br, {type}))
141 = "Type in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ limitResults type
142 processResult (ClassResult (br, {class_name,class_funs}))
143 = "Class in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ class_name +++ " with "
144 +++ toString (length class_funs) +++ " class functions"
145 processResult (ModuleResult (br, _))
146 = "Module in " +++ br.library +++ ": " +++ br.modul
148 limitResults :: String -> String
150 # lines = split "\n" s
151 | length lines > 4 = limitResults (join "\n" (take 3 lines) + "\n...")
152 = join "\n" (map maxWidth lines)
154 maxWidth :: String -> String
156 | size s > 80 = subString 0 77 s + "..."
160 Start :: *World -> (MaybeErrorString (), *World)
161 Start w = bot ("irc.freenode.net", 6667) startup shutdown () process w
163 toPrefix c = {irc_prefix=Nothing,irc_command=Right c}
164 startup = map toPrefix
165 [NICK "clooglebot" Nothing
166 ,USER "cloogle" "cloogle" "cloogle" "Cloogle bot"
167 ,JOIN (CSepList ["#cloogle", "#cleanlang"]) Nothing]
168 shutdown = map toPrefix [QUIT $ Just "Bye"]
170 process :: IRCMessage () *World -> (Maybe [IRCMessage], (), *World)
171 process im s w = case im.irc_command of
172 Left numr = (Just [], (), w)
173 Right cmd = case process` cmd w of
174 (Nothing, w) = (Nothing, (), w)
175 (Just cs, w) = (Just $ map toPrefix cs, (), w)
177 process` :: IRCCommand *World -> (Maybe [IRCCommand], *World)
178 process` (PRIVMSG t m) w
180 # (msgs, w) = realProcess (split " " $ m % (1, size m)) w
181 = (Just $ map (PRIVMSG t) msgs, w)
183 process` (PING t mt) w = (Just [PONG t mt], w)
184 process` _ w = (Just [], w)
186 realProcess :: [String] *World -> ([String], *World)
187 realProcess ["help",x:xs] w = ((case x of
189 [ "Usage: !help [ARG]"
190 , "Show this help, or the specific help of the argument"]
192 [ "Usage: !ping [ARG [ARG ...]]"
193 , "Ping the bot, it will pong the arguments back"]
195 [ "Usage: !shorten URL [URL [URL ...]]"
196 , "Shorten the given urls with the cloo.gl url shortener"]
198 [ "Usage: !query QUERY"
199 , "Query QUERY in cloogle and return the results"]
203 x = ["Unknown command: " +++ x]
205 realProcess ["help"] w = (
206 ["Type !help cmd for command specific help"
207 ,"available commands: help, ping, shorten, query, restart"], w)
208 realProcess ["ping":xs] w = (["pong " +++ join " " xs], w)
209 realProcess ["shorten":xs] w = case xs of
210 [] = (["shorten requires at least one argument"], w)
211 xs = mapSt shorten xs w
212 realProcess ["query":xs] w = case xs of
213 [] = (["query requires one or more arguments"], w)
214 xs = appFst (split "\n") $ cloogle (join " " xs) w
215 realProcess ["restart"] w = abort "Restarted"
216 realProcess ["restart":_] w = (["restart takes no arguments"], w)
217 realProcess [c:_] w = ([join " " [
218 "Unknown cmd: ", c, ", type !help to get help"]], w)