-
Notifications
You must be signed in to change notification settings - Fork 1
/
WebServerFct.sml
153 lines (132 loc) · 5.42 KB
/
WebServerFct.sml
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
(* Simple HTTP server (needs Socket) as a functor.
Initially based on example code by Peter Sestoft.
Authors: Ken Friis Larsen ([email protected]) and Peter Sestoft ([email protected])
Compile: mosmlc -toplevel HtmlUtils.sml WebServerFct.sml WebApp.sml -o appserver
Start: appserver
Stop: ctrl-C
*)
signature WebApp =
sig type state
val initial : state
val response : string * state -> HtmlUtils.reply * state
end
functor WebServerFct (App : WebApp) :>
sig type port = int
val start : port option -> unit
end =
struct
type port = int
val server = "Moscow ML HTTP demo app server"
val myaddr = "0.0.0.0"
val defaultPort = 4242
val admin = "[email protected]"
fun log msg = print msg;
fun date () = Date.toString(Date.fromTimeUniv(Time.now()))
fun mkheader header status fields mimetype len =
(log " "; log status; log " "; log (Int.toString len); log "\n";
concat ([header, "\n", "Date: ", date(), "\n", "Server: ", server, "\n"]
@ fields
@ ["Content-type: ", mimetype, "\n",
"Content-length: ", Int.toString len, "\n\n"]))
val okheader =
mkheader "HTTP/1.0 200 OK" "200" []
fun movpermheader newpath =
mkheader "HTTP/1.0 301 Moved permanently" "301"
["Location: " ^ newpath ^ "\n"] "text/html"
fun redirectheader newpath =
mkheader "HTTP/1.0 302 Moved Temporarily" "302"
["Location: " ^ newpath ^ "\n"] "text/html"
val forbiddenheader =
mkheader "HTTP/1.0 403 Forbidden" "403" [] "text/html"
val notfoundheader =
mkheader "HTTP/1.0 404 Not Found" "404" [] "text/html"
val errorheader =
mkheader "HTTP/1.0 500 Internal server error" "500" [] "text/html"
val notimplheader =
mkheader "HTTP/1.0 501 Not implemented" "501" [] "text/plain"
exception Notimplemented
(* fun mkheader header len = *)
(* let val date = Date.toString(Date.fromTimeUniv(Time.now())) *)
(* in *)
(* concat [header, "\n", *)
(* "Date: ", date, "\n", *)
(* "Server: ", server, "\n", *)
(* "Content-type: text/html\n", *)
(* "Content-length: ", Int.toString len, "\n\n"] *)
(* end *)
(* val okheader = mkheader "HTTP/1.0 200 OK" *)
(* val errorheader = mkheader "HTTP/1.0 500 Internal server error" *)
datatype reply = datatype HtmlUtils.reply
datatype result = Result of reply | Failure of exn
fun send sock s =
Socket.sendVec(sock, {buf=Byte.stringToBytes s, ofs=0, size=NONE})
fun senddoc sock header contents =
let val hdr = header (size contents)
in print hdr; send sock hdr; send sock contents end
fun addheader sock data =
case data of
Result(Html s) => senddoc sock (okheader "text/html") s
| Result(Redirect location) => senddoc sock (redirectheader location) ""
| Failure Notimplemented => senddoc sock notimplheader "Only GET request are implemented"
| Failure e => senddoc sock errorheader
("<HTML><HEAD>\n<TITLE>500 Internal Server Error</TITLE></HEAD>\n\
\<BODY>\n<H1>Internal Server Error</H1>\n\
\The server could not handle your request.\n\
\"^exnName e^" "^exnMessage e^"</BODY></HTML>\n")
(* Convert %xy to the character with hex code xy. No checks done. *)
fun xurldecode s =
let fun hexval c =
if #"0" <= c andalso c <= #"9" then ord c - 48
else (ord c - 55) mod 32;
fun loop [] acc = implode (rev acc)
| loop (#"%" :: cr) acc =
(case cr of
c1 :: c2 :: cr' =>
loop cr' (chr (16 * hexval c1 + hexval c2) :: acc)
| _ => loop cr (#"%" :: acc))
| loop (c :: cr) acc = loop cr (c :: acc)
in loop (explode s) [] end
fun parseRequest inp =
let open Substring
val _ = log (string (takel (Char.notContains "\r\n") (all inp)))
val (method, sus1) = splitl Char.isAlpha (all inp)
val _ = if string method <> "GET" then raise Notimplemented else ()
val path1 = string (trimr 1 (#1 (position "HTTP" (triml 2 sus1))))
val path2 = xurldecode path1
in path2
end
fun start portOpt =
let val sock = Socket.inetStream ()
val port = Option.getOpt (portOpt, defaultPort)
val addr = Socket.inetAddr myaddr port
val buf = Word8Array.array(10000, 0w0)
fun gethttprequest sock =
let val got = Socket.recvArr(sock, {buf = buf, ofs=0, size=NONE})
in Byte.unpackString(Word8ArraySlice.slice(buf, 0, SOME got))
end
fun robustResponse sock state =
let val (result, newState) = App.response(parseRequest(gethttprequest sock), state)
in (Result result, newState)
end handle e as Fail s => (log("[ Fail " ^ s ^ "]"); (Failure e, state))
| Interrupt => raise Interrupt
| e => (Failure e, state)
fun next state =
let val (sock', a) = Socket.accept sock
val _ = (log (Socket.getinetaddr a); log " ["; log (date()); log "] ")
val (result, newState) = robustResponse sock' state
in addheader sock' result
; Socket.close sock'
; next newState
end
prim_val catch_interrupt : bool -> unit = 1 "sys_catch_break"
in
catch_interrupt true;
Socket.bind(sock, addr);
Socket.listen(sock, 150);
print "Starting HTTP server\n";
app print ["Go to: http://", myaddr, ":", Int.toString port, " to enjoy it.\n"];
(next App.initial) handle Interrupt => ();
print "Shutting down HTTP server\n";
Socket.close sock
end
end