1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
implementation module CLPM.Util
import StdEnv
import TCPIP
import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Functor
import Data.List
import Data.Tuple
import Internet.HTTP
from Text import instance + String
TIMEOUT :== Just 10000
parse :: (String -> MaybeErrorString a) | Parse a
parse = Parse o fromString
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 " + server_name + " 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 = 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 :: HTTPResponse !*(ch .a) !*env
-> *(MaybeErrorString HTTPResponse, !*(ch .a), !*env)
| Receive ch & ChannelEnv env*/
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
syscall :: !String !*World -> !*(!Int, !*World)
syscall cmd w = code {
ccall system "s:I:A"
}
|
