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 TIMEOUT :== Just 10000
  33 SERVER :== "irc.freenode.net"
  34
  35 doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
  36 doRequest req w
  37 # (ip,w) = lookupIPAddress server_name w
  38 | isNothing ip
  39         = (Error $ "DNS lookup for " + server_name + " failed.", w)
  40 # (Just ip) = ip
  41 # (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
  42 | rpt == TR_Expired
  43         = (Error $ "Connection to " + toString ip + " timed out.", w)
  44 | rpt == TR_NoSuccess
  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
  48 | rpt <> TR_Success
  49         = (Error $ "Could not send request to " + server_name + ".", w)
  50 # (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
  51 | rpt <> TR_Success
  52         = (Error $ "Did not receive a reply from " + server_name + ".", w)
  53 # resp = 'CM'.join $ parseResponse <$> toString <$> resp
  54 | isNothing 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)
  59 = (resp,w)
  60 where
  61         server_name = req.server_name
  62         receiveRest resp chan w
  63         # cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
  64         | isNothing cl
  65                 = (Ok resp, chan, w)
  66         | size resp.rsp_data >= toInt (fromJust cl)
  67                 = (Ok resp, chan, w)
  68         # (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
  69         | rpt <> TR_Success
  70                 = (Error $ server_name + " hung up during transmission.", chan, w)
  71         = receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
  72
  73 import StdMisc
  74 import StdDebug
  75
  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)
  82 # resp = fromOk er
  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
  93                                 } (maxRedirects-1) w
  94 = (er, w)
  95
  96 shorten :: String *World -> (String, *World)
  97 shorten s w
  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
 101                 { newHTTPRequest
 102                 & req_method = HTTP_POST
 103                 , req_path = "/"
 104                 , server_name = "cloo.gl"
 105                 , server_port = 80
 106                 , req_headers = 'DM'.fromList
 107                         [("Content-Type", "application/x-www-form-urlencoded")
 108                         ,("Content-Length", toString $ size data)
 109                         ,("Accept", "*/*")]
 110                 , req_data = data} w
 111 | isError mer = ("request failed: " + fromError mer, w)
 112 # resp = fromOk mer
 113 = (resp.rsp_data, w)
 114
 115 cloogle :: String *World -> (String, *World)
 116 cloogle data w
 117 # (mer, w) = doRequestL
 118                 { newHTTPRequest
 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)
 125 # resp = fromOk mer
 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)
 131         where
 132                 processResults :: Response -> String
 133                 processResults resp
 134                 | resp.return > 127 = "Failed: return code: " + toString resp.return + ", " + resp.msg
 135                 = join "\n" $ map processResult $ take 3 resp.data
 136
 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
 147
 148                 limitResults :: String -> String
 149                 limitResults s
 150                 # lines = split "\n" s
 151                 | length lines > 4 = limitResults (join "\n" (take 3 lines) + "\n...")
 152                 = join "\n" (map maxWidth lines)
 153
 154                 maxWidth :: String -> String
 155                 maxWidth s
 156                 | size s > 80 = subString 0 77 s + "..."
 157                 = s
 158
 159
 160 Start :: *World -> (MaybeErrorString (), *World)
 161 Start w = bot ("irc.freenode.net", 6667) startup shutdown () process w
 162         where
 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"]
 169
 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)
 176
 177                 process` :: IRCCommand *World -> (Maybe [IRCCommand], *World)
 178                 process` (PRIVMSG t m) w
 179                         | m.[0] == '!'
 180                                 # (msgs, w) = realProcess (split " " $ m % (1, size m)) w
 181                                 = (Just $ map (PRIVMSG t) msgs, w)
 182                         = (Just [], w)
 183                 process` (PING t mt) w = (Just [PONG t mt], w)
 184                 process` _ w = (Just [], w)
 185
 186                 realProcess :: [String] *World -> ([String], *World)
 187                 realProcess ["help",x:xs] w = ((case x of
 188                         "help" =
 189                                 [ "Usage: !help [ARG]"
 190                                 , "Show this help, or the specific help of the argument"]
 191                         "ping" =
 192                                 [ "Usage: !ping [ARG [ARG ...]]"
 193                                 , "Ping the bot, it will pong the arguments back"]
 194                         "shorten" =
 195                                 [ "Usage: !shorten URL [URL [URL ...]]"
 196                                 , "Shorten the given urls with the cloo.gl url shortener"]
 197                         "query" =
 198                                 [ "Usage: !query QUERY"
 199                                 , "Query QUERY in cloogle and return the results"]
 200                         "restart" =
 201                                 [ "Usage: !restart"
 202                                 , "Restart the bot"]
 203                         x = ["Unknown command: " +++ x]
 204                         ), w)
 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)