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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
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
import System.Directory
import System.File
import System.FilePath
from Text import instance + String
TIMEOUT :== Just 10000
instance Parse Int
where
Parse [] = Error "Empty string for Int."
Parse cs
| all isDigit cs = Ok $ toInt $ toString cs
| otherwise = Error "Unexpected character in Int."
instance Parse (Maybe Int)
where
Parse ['?'] = Ok $ Nothing
Parse cs = Just <$> Parse cs
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"
}
recursivelyRemove :: !FilePath !*World -> *(MaybeErrorString (), !*World)
recursivelyRemove fp w
| isMember (last $ takeWhile ((<>) "") $ iterate (snd o splitFileName) fp)
[".", ".."] = (Ok (), w)
# (inf,w) = getFileInfo fp w
| isError inf = cast (inf, w)
| not (fromOk inf).directory = cast $ deleteFile fp w
# (fps,w) = readDirectory fp w
| isError fps = cast (fps,w)
# (rem,w) = appFst sequence $
seqList (map (recursivelyRemove o ((</>) fp)) (fromOk fps)) w
| isError rem = (Error $ fromError rem,w)
= cast $ removeDirectory fp w
where
cast :: (MaybeOSError a, *World) -> (MaybeErrorString (), *World)
cast (Error e, w) = (Error $ snd e, w)
cast (Ok _, w) = (Ok (), w)
|
