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