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
  13 import Control.Applicative
  14 import qualified Control.Monad as CM
  15 import qualified Data.Map as DM
  16 from Control.Monad import class Monad, instance Monad Maybe
  17 from Text.Encodings.UrlEncoding import urlEncode
  18 import Internet.HTTP
  19 import Data.Error
  20 import Data.List
  21 import Data.Functor
  22 import Data.Tuple
  23
  24 import TCPIP
  25
  26 commands :: [String]
  27 commands = map toString
  28         [NICK "clooglebot"
  29         ,USER "cloogle" 0 "Cloogle bot"
  30         ,JOIN [("#cloogle", Nothing)]
  31         ]
  32
  33 TIMEOUT :== Just 10000
  34 SERVER :== "irc.freenode.net"
  35
  36 KEY :== "PRIVMSG #cloogle :!"
  37
  38 doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
  39 doRequest req w
  40 # (ip,w) = lookupIPAddress server_name w
  41 | isNothing ip
  42         = (Error $ "DNS lookup for " + server_name + " failed.", w)
  43 # (Just ip) = ip
  44 # (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
  45 | rpt == TR_Expired
  46         = (Error $ "Connection to " + toString ip + " timed out.", w)
  47 | rpt == TR_NoSuccess
  48         = (Error $ "Could not connect to " + server_name + ".", w)
  49 # (Just {sChannel,rChannel}) = chan
  50 # (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq req) sChannel w
  51 | rpt <> TR_Success
  52         = (Error $ "Could not send request to " + server_name + ".", w)
  53 # (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
  54 | rpt <> TR_Success
  55         = (Error $ "Did not receive a reply from " + server_name + ".", w)
  56 # resp = 'CM'.join $ parseResponse <$> toString <$> resp
  57 | isNothing resp
  58         # w = closeChannel sChannel (closeRChannel rChannel w)
  59         = (Error $ "Server did not respond with HTTP.", w)
  60 # (resp,rChannel,w) = receiveRest (fromJust resp) rChannel w
  61 # w = closeChannel sChannel (closeRChannel rChannel w)
  62 = (resp,w)
  63 where
  64         server_name = req.server_name
  65         receiveRest resp chan w
  66         # cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
  67         | isNothing cl
  68                 = (Ok resp, chan, w)
  69         | size resp.rsp_data >= toInt (fromJust cl)
  70                 = (Ok resp, chan, w)
  71         # (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
  72         | rpt <> TR_Success
  73                 = (Error $ server_name + " hung up during transmission.", chan, w)
  74         = receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
  75
  76 shorten :: String *World -> (String, *World)
  77 shorten s w
  78 # data = "type=regular&url="+urlEncode s+"&token=a"
  79 # (mer, w) = doRequest
  80                 { newHTTPRequest
  81                 & req_method = HTTP_POST
  82                 , req_path = "/"
  83                 , server_name = "cloo.gl"
  84                 , server_port = 80
  85                 , req_headers = 'DM'.fromList
  86                         [("Content-Type", "application/x-www-form-urlencoded")
  87                         ,("Content-Length", toString $ size data)
  88                         ,("Accept", "*/*")]
  89                 , req_data = data} w
  90 | isError mer = ("request failed: " + fromError mer, w)
  91 # resp = fromOk mer
  92 = (resp.rsp_data, w)
  93
  94 send :: [String] TCP_DuplexChannel *World -> (TCP_DuplexChannel, *World)
  95 send [] chan w = (chan, w)
  96 send [msg:msgs] {sChannel,rChannel} w
  97 # (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq msg) sChannel w
  98 | rpt <> TR_Success = abort "Could not send request\n"
  99 = send msgs {sChannel=sChannel,rChannel=rChannel} w
 100
 101 recv :: TCP_DuplexChannel *World -> (Maybe String, TCP_DuplexChannel, *World)
 102 recv {sChannel,rChannel} w
 103 # (rpt, resp, rChannel, w) = receive_MT TIMEOUT rChannel w
 104 | rpt == TR_Expired = (Nothing, {sChannel=sChannel,rChannel=rChannel}, w)
 105 | rpt == TR_NoSuccess || isNothing resp = abort "Halp?\n"
 106 = (toString <$> resp, {sChannel=sChannel,rChannel=rChannel}, w)
 107
 108 msg :: (String -> IRCCommands)
 109 msg = PRIVMSG "#cloogle"
 110
 111 process :: *File TCP_DuplexChannel *World -> (*File, TCP_DuplexChannel, *World)
 112 process io chan w
 113 # (mr, chan, w) = recv chan w
 114 | isNothing mr = process io chan w
 115 # resp = fromJust mr
 116 #! io = io <<< ("Received: " +++ resp +++ "\n")
 117 # ind = indexOf KEY resp
 118 | ind >= 0
 119         # cmd = split " " $ rtrim $ subString (ind + size KEY) (size resp) resp
 120         #! io =  io <<< ("Received command: " +++ printToString cmd +++ "\n")
 121         # (w, toSend) = case cmd of
 122                 ["stop":_] = (w, Nothing)
 123                 ["ping":xs] = (w, Just [msg $ "pong " +++ join " " xs])
 124                 ["short"] = (w, Just [msg $ "short requires an url argument"])
 125                 ["short":xs]
 126                         # (s, w) = shorten (join " " xs) w
 127                         = (w, Just [msg s])
 128                 ["help"] = (w, Just
 129                         [msg "type !help cmd for command specific help"
 130                         ,msg "available commands: help, short, ping"])
 131                 ["help":c:_] = (w, case c of
 132                         "help"  = Just [msg "help  [CMD] - I will print general help or the help of CMD"]
 133                         "short" = Just [msg "short  URL  - I will give the url to https://cloo.gl shortening service and post back the result"]
 134                         "ping"  = Just [msg "ping  [TXT] - I will reply with pong and the optionar TXT"]
 135                         _ = Just [msg "Unknown command"])
 136                 [c:_] = (w, Just [msg $ join " " ["unknown command: " , c, ",  type !help to get help"]])
 137         | isNothing toSend = (io, chan, w)
 138         # (chan, w) = send (map toString $ fromJust toSend) chan w
 139         = process io chan w
 140 | indexOf "PING :" resp >= 0
 141         # cmd = rtrim $ subString (indexOf "PING :" resp + size "PING :") (size resp) resp
 142         #! io = io <<< (toString $ PONG cmd Nothing) <<< "\n"
 143         # (chan, w) = send [toString $ PONG cmd Nothing] chan w
 144         = process io chan w
 145 = process io chan w
 146
 147 Start :: *World -> *World
 148 Start w
 149 # (io, w) = stdio w
 150 # (ip, w) = lookupIPAddress SERVER w
 151 | isNothing ip = abort $ "DNS lookup for " +++ SERVER +++ " failed\n"
 152 # (Just ip) = ip
 153 # (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, 6667) w
 154 | rpt == TR_Expired = abort $ "Connection to " +++ SERVER +++ " timed out\n"
 155 | rpt == TR_NoSuccess = abort $ "Could not connect to " +++ SERVER +++ "\n"
 156 # chan = fromJust chan
 157 # (chan, w) = send commands chan w
 158 # (io, chan, w) = process io chan w
 159 # ({sChannel,rChannel}, w) = send [toString $ QUIT Nothing] chan w
 160 # (_, w) = fclose io w
 161 = closeChannel sChannel (closeRChannel rChannel w)