9 from Data.Func import $
10 from Text import class Text(..), instance Text String, instance + String
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
27 commands = map toString
29 ,USER "cloogle" 0 "Cloogle bot"
30 ,JOIN [("#cloogle", Nothing)]
33 TIMEOUT :== Just 10000
34 SERVER :== "irc.freenode.net"
36 KEY :== "PRIVMSG #cloogle :!"
38 doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
40 # (ip,w) = lookupIPAddress server_name w
42 = (Error $ "DNS lookup for " + server_name + " failed.", w)
44 # (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
46 = (Error $ "Connection to " + toString ip + " timed out.", w)
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
52 = (Error $ "Could not send request to " + server_name + ".", w)
53 # (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
55 = (Error $ "Did not receive a reply from " + server_name + ".", w)
56 # resp = 'CM'.join $ parseResponse <$> toString <$> 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)
64 server_name = req.server_name
65 receiveRest resp chan w
66 # cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
69 | size resp.rsp_data >= toInt (fromJust cl)
71 # (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
73 = (Error $ server_name + " hung up during transmission.", chan, w)
74 = receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
76 shorten :: String *World -> (String, *World)
78 # data = "type=regular&url="+urlEncode s+"&token=a"
79 # (mer, w) = doRequest
81 & req_method = HTTP_POST
83 , server_name = "cloo.gl"
85 , req_headers = 'DM'.fromList
86 [("Content-Type", "application/x-www-form-urlencoded")
87 ,("Content-Length", toString $ size data)
90 | isError mer = ("request failed: " + fromError mer, w)
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
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)
108 msg :: (String -> IRCCommands)
109 msg = PRIVMSG "#cloogle"
111 process :: *File TCP_DuplexChannel *World -> (*File, TCP_DuplexChannel, *World)
113 # (mr, chan, w) = recv chan w
114 | isNothing mr = process io chan w
116 #! io = io <<< ("Received: " +++ resp +++ "\n")
117 # ind = indexOf KEY resp
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"])
126 # (s, w) = shorten (join " " xs) w
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
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
147 Start :: *World -> *World
150 # (ip, w) = lookupIPAddress SERVER w
151 | isNothing ip = abort $ "DNS lookup for " +++ SERVER +++ " failed\n"
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)