cloogle.icl

   1 module cloogle
   2
   3 import Cloogle
   4 import GenPrint
   5 import StdEnv
   6
   7 import Data.Functor
   8 import Data.Maybe
   9 import Data.Either
  10 from Data.Func import $, mapSt
  11 from Text import class Text(..), instance Text String, instance + String
  12
  13 import Text.JSON
  14
  15 import Text.URI
  16
  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
  22 import Internet.HTTP
  23 import Data.Error
  24 import Data.List
  25 import Data.Functor
  26 import Data.Tuple
  27
  28 import TCPIP
  29 import IRC
  30 import IRCBot
  31
  32 commands :: [String]
  33 commands = map toString
  34         [NICK "clooglebot" Nothing
  35         ,USER "cloogle" "0" "cloogle" "Cloogle bot"
  36         ,JOIN (CSepList ["#cloogle"]) Nothing
  37         ]
  38
  39 TIMEOUT :== Just 10000
  40 SERVER :== "irc.freenode.net"
  41
  42 KEY :== "PRIVMSG #cloogle :!"
  43
  44 doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
  45 doRequest req w
  46 # (ip,w) = lookupIPAddress server_name w
  47 | isNothing ip
  48         = (Error $ "DNS lookup for " + server_name + " failed.", w)
  49 # (Just ip) = ip
  50 # (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
  51 | rpt == TR_Expired
  52         = (Error $ "Connection to " + toString ip + " timed out.", w)
  53 | rpt == TR_NoSuccess
  54         = (Error $ "Could not connect to " + server_name + ".", w)
  55 # (Just {sChannel,rChannel}) = chan
  56 # (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq req) sChannel w
  57 | rpt <> TR_Success
  58         = (Error $ "Could not send request to " + server_name + ".", w)
  59 # (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
  60 | rpt <> TR_Success
  61         = (Error $ "Did not receive a reply from " + server_name + ".", w)
  62 # resp = 'CM'.join $ parseResponse <$> toString <$> resp
  63 | isNothing resp
  64         # w = closeChannel sChannel (closeRChannel rChannel w)
  65         = (Error $ "Server did not respond with HTTP.", w)
  66 # (resp,rChannel,w) = receiveRest (fromJust resp) rChannel w
  67 # w = closeChannel sChannel (closeRChannel rChannel w)
  68 = (resp,w)
  69 where
  70         server_name = req.server_name
  71         receiveRest resp chan w
  72         # cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
  73         | isNothing cl
  74                 = (Ok resp, chan, w)
  75         | size resp.rsp_data >= toInt (fromJust cl)
  76                 = (Ok resp, chan, w)
  77         # (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
  78         | rpt <> TR_Success
  79                 = (Error $ server_name + " hung up during transmission.", chan, w)
  80         = receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
  81
  82 import StdMisc
  83 import StdDebug
  84
  85 doRequestL :: HTTPRequest Int *World -> *(MaybeErrorString HTTPResponse, *World)
  86 doRequestL req 0 w = (Error "Maximal redirect number exceeded", w)
  87 doRequestL req maxRedirects w
  88 | not (trace_tn $ toString req) = undef
  89 # (er, w) = doRequest req w
  90 | isError er = (er, w)
  91 # resp = fromOk er
  92 | isMember resp.HTTPResponse.rsp_code [301, 302, 303, 307, 308]
  93         = case lookup "Location" resp.HTTPResponse.rsp_headers of
  94                 Nothing = (Error $ "Redirect given but no Location header", w)
  95                 Just loc = case parseURI loc of
  96                         Nothing = (Error $ "Redirect URI couldn't be parsed", w)
  97                         Just uri = doRequestL {req
  98                                 & server_name = maybe loc id uri.uriRegName
  99                                 , server_port = maybe 80 id uri.uriPort
 100                                 , req_path = uri.uriPath
 101                                 , req_query = maybe "" ((+++) "?") uri.uriQuery
 102                                 } (maxRedirects-1) w
 103 = (er, w)
 104
 105 shorten :: String *World -> (String, *World)
 106 shorten s w
 107 # s = if (startsWith "http://" s) s (if (startsWith "https://" s) s ("http://" + s))
 108 # data = "type=regular&url="+urlEncode s+"&token=a"
 109 # (mer, w) = doRequest
 110                 { newHTTPRequest
 111                 & req_method = HTTP_POST
 112                 , req_path = "/"
 113                 , server_name = "cloo.gl"
 114                 , server_port = 80
 115                 , req_headers = 'DM'.fromList
 116                         [("Content-Type", "application/x-www-form-urlencoded")
 117                         ,("Content-Length", toString $ size data)
 118                         ,("Accept", "*/*")]
 119                 , req_data = data} w
 120 | isError mer = ("request failed: " + fromError mer, w)
 121 # resp = fromOk mer
 122 = (resp.rsp_data, w)
 123
 124 cloogle :: String *World -> (String, *World)
 125 cloogle data w
 126 # (mer, w) = doRequestL
 127                 { newHTTPRequest
 128                 & req_path = "/api.php"
 129                 , req_query = "?str=" + urlEncode data
 130                 , req_headers = 'DM'.fromList [("User-Agent", "cloogle-irc")]
 131                 , server_name = "cloogle.org"
 132                 , server_port = 80} 10 w
 133 | isError mer = ("request failed: " + fromError mer, w)
 134 # resp = fromOk mer
 135 = case fromJSON $ fromString resp.HTTPResponse.rsp_data of
 136         Nothing = ("couldn't parse json", w)
 137         Just clr = ("Results for " + data + " -- https://cloogle.org/#" + replaceSubString "+" "%20" (urlEncode data) + "\n" +
 138                         processResults clr, w)
 139         where
 140                 processResults :: Response -> String
 141                 processResults resp
 142                 | resp.return > 127 = "Failed: return code: " + toString resp.return + ", " + resp.msg
 143                 = join "\n" $ map processResult $ take 3 resp.data
 144
 145                 processResult :: Result -> String
 146                 processResult (FunctionResult (br, {func}))
 147                         = "Function in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ func
 148                 processResult (TypeResult (br, {type}))
 149                         = "Type in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ limitResults type
 150                 processResult (ClassResult (br, {class_name,class_funs}))
 151                         = "Class in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ class_name +++ " with "
 152                                 +++ toString (length class_funs) +++ " class functions"
 153                 //processResult (MacroResult (br, {macro_name}))
 154                 //      = "Macro in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ macro_name
 155                 processResult (ModuleResult (br, _))
 156                         = "Module in " +++ br.library +++ ": " +++ br.modul
 157
 158                 limitResults :: String -> String
 159                 limitResults s
 160                 # lines = split "\n" s
 161                 | length lines > 4 = limitResults (join "\n" (take 3 lines) + "\n...")
 162                 = join "\n" (map maxWidth lines)
 163
 164                 maxWidth :: String -> String
 165                 maxWidth s
 166                 | size s > 80 = subString 0 77 s + "..."
 167                 = s
 168
 169
 170 Start :: *World -> (MaybeErrorString (), *World)
 171 Start w = bot ("irc.freenode.net", 6667) startup shutdown () process w
 172         where
 173                 toPrefix c = {irc_prefix=Nothing,irc_command=Right c}
 174                 startup = map toPrefix
 175                         [NICK "clooglebot" Nothing
 176                         ,USER "cloogle" "cloogle" "cloogle" "Cloogle bot"
 177                         ,JOIN (CSepList ["#cloogle"]) Nothing]
 178                 shutdown = map toPrefix [QUIT $ Just "Bye"]
 179
 180                 process :: IRCMessage () *World -> (Maybe [IRCMessage], (), *World)
 181                 process im s w = case im.irc_command of
 182                         Left numr = (Just [], (), w)
 183                         Right cmd = case process` cmd w of
 184                                 (Nothing, w) = (Nothing, (), w)
 185                                 (Just cs, w) = (Just $ map toPrefix cs, (), w)
 186
 187                 process` :: IRCCommand *World -> (Maybe [IRCCommand], *World)
 188                 process` (PRIVMSG t m) w
 189                         | m.[0] == '!'
 190                                 # (msgs, w) = realProcess (split " " $ m % (1, size m)) w
 191                                 = (Just $ map (PRIVMSG t) msgs, w)
 192                         = (Nothing, w)
 193                 process` (PING t mt) w = (Just [PONG t mt], w)
 194                 process` _ w = (Just [], w)
 195
 196                 realProcess :: [String] *World -> ([String], *World)
 197                 realProcess ["help",x:xs] w = ((case x of
 198                         "help" =
 199                                 [ "Usage: !help [ARG]"
 200                                 , "Show this help, or the specific help of the argument"]
 201                         "ping" =
 202                                 [ "Usage: !ping [ARG [ARG ...]]"
 203                                 , "Ping the bot, it will pong the arguments back"]
 204                         "shorten" =
 205                                 [ "Usage: !shorten URL [URL [URL ...]]"
 206                                 , "Shorten the given urls with the cloo.gl url shortener"]
 207                         "query" =
 208                                 [ "Usage: !query QUERY"
 209                                 , "Query QUERY in cloogle and return the results"]
 210                         "restart" =
 211                                 [ "Usage: !restart"
 212                                 , "Restart the bot"]
 213                         x = ["Unknown command: " +++ x]
 214                         ), w)
 215                 realProcess ["help"] w = (
 216                         ["Type !help cmd for command specific help"
 217                         ,"available commands: help, ping, shorten, query"], w)
 218                 realProcess ["ping":xs] w = (["pong " +++ join " " xs], w)
 219                 realProcess ["shorten":xs] w = case xs of
 220                         [] = (["shorten requires at least one argument"], w)
 221                         xs = mapSt shorten xs w
 222                 realProcess ["query":xs] w = case xs of
 223                         [] = (["query requires one or more arguments"], w)
 224                         xs = (["Not implemented yet..."], w)
 225                 realProcess ["restart"] w = abort "Restarted"
 226                 realProcess ["restart":_] w = (["restart takes no arguments"], w)
 227                 realProcess [c:_] w = ([join " " [
 228                         "Unknown cmd: ", c, ",  type !help to get help"]], w)