Commit 5c61e750 authored by Mart Lubbers's avatar Mart Lubbers

Merge branch 'master' of github.com:clean-cloogle/clean-irc

parents 72720f27 acc4a4b8
......@@ -125,7 +125,7 @@ illegal = ['\x00','\r','\n']
instance toString IRCNumReply where
toString m = lpad (toString $ toInt m.irc_reply) 3 '0' <+ " " <+
m.irc_recipient <+ concat (gIRCPrint{|*|} m.irc_message)
m.irc_recipient <+ " " <+ concat (gIRCPrint{|*|} m.irc_message)
instance toString IRCMessage where
toString m = maybe "" (\s->either ((<+) ":") id s <+ " ") m.irc_prefix
<+ either toString toString m.irc_command
......
......@@ -13,9 +13,10 @@ CLMLIBS:=\
-I $(CLEAN_HOME)/lib/Generics\
-I $(CLEAN_HOME)/lib/TCPIP\
-I $(CLEAN_HOME)/lib/Dynamics\
-I ~/projects/gast/Libraries\
-I ./libcloogle
BINARIES:=IRC cloogle
BINARIES:=IRC cloogle test
all: $(BINARIES)
......
......@@ -10,6 +10,8 @@ import Data.Either
from Data.Func import $, mapSt
from Text import class Text(..), instance Text String, instance + String
import Internet.HTTP
import Text.JSON
import Text.URI
......@@ -32,72 +34,11 @@ import IRCBot
TIMEOUT :== Just 10000
SERVER :== "irc.freenode.net"
doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
doRequest req w
# (ip,w) = lookupIPAddress server_name w
| isNothing ip
= (Error $ "DNS lookup for " + server_name + " failed.", w)
# (Just ip) = ip
# (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
| rpt == TR_Expired
= (Error $ "Connection to " + toString ip + " timed out.", w)
| rpt == TR_NoSuccess
= (Error $ "Could not connect to " + server_name + ".", w)
# (Just {sChannel,rChannel}) = chan
# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq req) sChannel w
| rpt <> TR_Success
= (Error $ "Could not send request to " + server_name + ".", w)
# (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
| rpt <> TR_Success
= (Error $ "Did not receive a reply from " + server_name + ".", w)
# resp = 'CM'.join $ parseResponse <$> toString <$> resp
| isNothing resp
# w = closeChannel sChannel (closeRChannel rChannel w)
= (Error $ "Server did not respond with HTTP.", w)
# (resp,rChannel,w) = receiveRest (fromJust resp) rChannel w
# w = closeChannel sChannel (closeRChannel rChannel w)
= (resp,w)
where
server_name = req.server_name
receiveRest resp chan w
# cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
| isNothing cl
= (Ok resp, chan, w)
| size resp.rsp_data >= toInt (fromJust cl)
= (Ok resp, chan, w)
# (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
| rpt <> TR_Success
= (Error $ server_name + " hung up during transmission.", chan, w)
= receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
import StdMisc
import StdDebug
doRequestL :: HTTPRequest Int *World -> *(MaybeErrorString HTTPResponse, *World)
doRequestL req 0 w = (Error "Maximal redirect number exceeded", w)
doRequestL req maxRedirects w
| not (trace_tn $ toString req) = undef
# (er, w) = doRequest req w
| isError er = (er, w)
# resp = fromOk er
| isMember resp.HTTPResponse.rsp_code [301, 302, 303, 307, 308]
= case lookup "Location" resp.HTTPResponse.rsp_headers of
Nothing = (Error $ "Redirect given but no Location header", w)
Just loc = case parseURI loc of
Nothing = (Error $ "Redirect URI couldn't be parsed", w)
Just uri = doRequestL {req
& server_name = maybe loc id uri.uriRegName
, server_port = maybe 80 id uri.uriPort
, req_path = uri.uriPath
, req_query = maybe "" ((+++) "?") uri.uriQuery
} (maxRedirects-1) w
= (er, w)
shorten :: String *World -> (String, *World)
shorten s w
# s = if (startsWith "http://" s) s (if (startsWith "https://" s) s ("http://" + s))
# data = "type=regular&url="+urlEncode s+"&token=a"
# (mer, w) = doRequest
# (mer, w) = doHTTPRequest
{ newHTTPRequest
& req_method = HTTP_POST
, req_path = "/"
......@@ -107,20 +48,20 @@ shorten s w
[("Content-Type", "application/x-www-form-urlencoded")
,("Content-Length", toString $ size data)
,("Accept", "*/*")]
, req_data = data} w
, req_data = data} 10000 w
| isError mer = ("request failed: " + fromError mer, w)
# resp = fromOk mer
= (resp.rsp_data, w)
cloogle :: String *World -> (String, *World)
cloogle data w
# (mer, w) = doRequestL
# (mer, w) = doHTTPRequestL
{ newHTTPRequest
& req_path = "/api.php"
, req_query = "?str=" + urlEncode data
, req_headers = 'DM'.fromList [("User-Agent", "cloogle-irc")]
, server_name = "cloogle.org"
, server_port = 80} 10 w
, server_port = 80} 10000 10 w
| isError mer = ("request failed: " + fromError mer, w)
# resp = fromOk mer
= case fromJSON $ fromString resp.HTTPResponse.rsp_data of
......@@ -170,18 +111,22 @@ Start w = bot ("irc.freenode.net", 6667) startup shutdown () process w
process :: IRCMessage () *World -> (Maybe [IRCMessage], (), *World)
process im s w = case im.irc_command of
Left numr = (Just [], (), w)
Right cmd = case process` cmd w of
Right cmd = case process` im.irc_prefix cmd w of
(Nothing, w) = (Nothing, (), w)
(Just cs, w) = (Just $ map toPrefix cs, (), w)
process` :: IRCCommand *World -> (Maybe [IRCCommand], *World)
process` (PRIVMSG t m) w
process` :: (Maybe (Either IRCUser String)) IRCCommand *World -> (Maybe [IRCCommand], *World)
process` (Just (Left user)) (PRIVMSG t m) w
| m.[0] == '!'
# (msgs, w) = realProcess (split " " $ m % (1, size m)) w
= (Just $ map (PRIVMSG t) msgs, w)
= (Just $ map (PRIVMSG recipient) msgs, w)
= (Just [], w)
process` (PING t mt) w = (Just [PONG t mt], w)
process` _ w = (Just [], w)
where
recipient = case (\(CSepList [t:_]) -> t.[0]) t of
'#' -> t
_ -> CSepList [user.irc_nick]
process` _ (PING t mt) w = (Just [PONG t mt], w)
process` _ _ w = (Just [], w)
realProcess :: [String] *World -> ([String], *World)
realProcess ["help",x:xs] w = ((case x of
......
module test
import gast
import Gast
import IRC
import GenBimap
import Data.Func
import Data.Either
import Text
derive ggen IRCMessage
derive ggen IRCMessage, Either, IRCUser, IRCCommand, Maybe, CSepList, IRCNumReply, IRCReplies
derive genShow IRCMessage, Either, IRCUser, IRCCommand, Maybe, CSepList, IRCNumReply, IRCReplies
Start = Test [] pParsePrint
//Doesn't work, generates illegal irc commands with spaces in recipients
Start = concat $ Test [] pParsePrint
pParsePrint :: IRCMessage -> Bool
pParsePrint a = toString (parseIRCMessage (toString a)) == toString a
pParsePrint a
# str = toString a
= either (const False) ((==)str o toString) $ parseIRCMessage str
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment