cloogle.icl

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