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 $
  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 numbe 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                 ["stop":_] = (w, Nothing)
 171                 ["ping":xs] = (w, Just [msg $ "pong " +++ join " " xs])
 172                 ["query":xs]
 173                         # (s, w) = cloogle (join " " xs) w
 174                         = (w, Just $ map msg $ split "\n" s)
 175                 ["short"] = (w, Just [msg $ "short requires an url argument"])
 176                 ["short":xs]
 177                         # (s, w) = shorten (join " " xs) w
 178                         = (w, Just [msg s])
 179                 ["help"] = (w, Just
 180                         [msg "type !help cmd for command specific help"
 181                         ,msg "available commands: help, ping, query, short"])
 182                 ["help":c:_] = (w, case c of
 183                         "help"  = Just [msg "help  [CMD] - I will print general help or the help of CMD"]
 184                         "ping"  = Just [msg "ping  [TXT] - I will reply with pong and the optionar TXT"]
 185                         "query" = Just [msg "query QUERY - I will send QUERY to cloogle and post the results"]
 186                         "short" = Just [msg "short  URL  - I will give the url to https://cloo.gl shortening service and post back the result"]
 187                         _ = Just [msg "Unknown command"])
 188                 [c:_] = (w, Just [msg $ join " " ["unknown command: " , c, ",  type !help to get help"]])
 189 */
 190
 191 Start :: *World -> (MaybeErrorString (), *World)
 192 Start w = bot ("irc.freenode.net", 6667) startup shutdown () process w
 193         where
 194                 toPrefix c = {irc_prefix=Nothing,irc_command=Right c}
 195                 startup = map toPrefix
 196                         [NICK "clooglebot" Nothing
 197                         ,USER "cloogle" "cloogle" "cloogle" "Cloogle bot"
 198                         ,JOIN (CSepList ["#cloogle"]) Nothing]
 199                 shutdown = map toPrefix [QUIT $ Just "Bye"]
 200
 201                 process :: IRCMessage () *World -> (Maybe [IRCMessage], (), *World)
 202                 process im s w = case im.irc_command of
 203                         Left numr = (Just [], (), w)
 204                         Right cmd = case process` cmd w of
 205                                 (Nothing, w) = (Nothing, (), w)
 206                                 (Just cs, w) = (Just $ map toPrefix cs, (), w)
 207
 208                 process` :: IRCCommand *World -> (Maybe [IRCCommand], *World)
 209                 process` (PRIVMSG t m) w = (Just $ if (startsWith "!" m)
 210                                 (map (PRIVMSG t) $ realProcess $ split " " $ subString 1 (size m) m)
 211                         [], w)
 212                 process` (PING t mt) w = (Just [PONG t mt], w)
 213                 process` _ w = (Just [], w)
 214
 215                 realProcess :: [String] -> [String]
 216                 realProcess ["help":xs] =
 217                         ["type !help cmd for command specific help"
 218                         ,"available commands: help"]
 219                 realProcess [c:_] = [join " " ["unknown cmd: ", c, ",  type !help to get help"]]