cloogle.icl

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