33823
|
1 |
(* Title: Tools/WWW_Find/scgi_server.ML
|
33817
|
2 |
Author: Timothy Bourke, NICTA
|
|
3 |
|
|
4 |
Simple SCGI server.
|
|
5 |
*)
|
|
6 |
|
|
7 |
signature SCGI_SERVER =
|
|
8 |
sig
|
|
9 |
val max_threads : int Unsynchronized.ref
|
|
10 |
type handler = ScgiReq.t * Word8Vector.vector * (string -> unit) -> unit
|
|
11 |
val register : (string * Mime.t option * handler) -> unit
|
|
12 |
val server : string -> int -> unit
|
|
13 |
val server' : int -> string -> int -> unit (* keeps trying for port *)
|
|
14 |
end;
|
|
15 |
|
|
16 |
structure ScgiServer : SCGI_SERVER =
|
|
17 |
struct
|
|
18 |
val max_threads = Unsynchronized.ref 5;
|
|
19 |
|
|
20 |
type handler = ScgiReq.t * Word8Vector.vector * (string -> unit) -> unit;
|
|
21 |
|
|
22 |
local
|
|
23 |
val servers = Unsynchronized.ref (Symtab.empty : (Mime.t option * handler) Symtab.table);
|
|
24 |
in
|
|
25 |
fun register (name, mime, f) =
|
|
26 |
Unsynchronized.change servers (Symtab.update_new (name, (mime, f)));
|
|
27 |
fun lookup name = Symtab.lookup (!servers) name;
|
|
28 |
|
|
29 |
fun dump_handlers () = (
|
|
30 |
tracing(" with handlers:");
|
|
31 |
app (fn (x, _) => tracing (" - " ^ x)) (Symtab.dest (!servers)))
|
|
32 |
end;
|
|
33 |
|
|
34 |
fun server server_prefix port =
|
|
35 |
let
|
|
36 |
val passive_sock = SocketUtil.init_server_socket (SOME "localhost") port;
|
|
37 |
|
|
38 |
val thread_wait = ConditionVar.conditionVar ();
|
|
39 |
val thread_wait_mutex = Mutex.mutex ();
|
|
40 |
|
|
41 |
local
|
|
42 |
val threads = Unsynchronized.ref ([] : Thread.thread list);
|
|
43 |
fun purge () = Unsynchronized.change threads (filter Thread.isActive);
|
|
44 |
in
|
|
45 |
fun add_thread th = Unsynchronized.change threads (cons th);
|
|
46 |
|
|
47 |
fun launch_thread threadf =
|
|
48 |
(purge ();
|
|
49 |
if length (!threads) < (!max_threads) then ()
|
|
50 |
else (tracing ("Waiting for a free thread...");
|
|
51 |
ConditionVar.wait (thread_wait, thread_wait_mutex));
|
|
52 |
add_thread
|
39155
|
53 |
(Thread.fork (* FIXME avoid low-level Poly/ML thread primitives *)
|
33817
|
54 |
(fn () => exception_trace threadf,
|
|
55 |
[Thread.EnableBroadcastInterrupt true,
|
|
56 |
Thread.InterruptState
|
|
57 |
Thread.InterruptAsynchOnce])))
|
|
58 |
end;
|
|
59 |
|
|
60 |
fun loop () =
|
|
61 |
let
|
|
62 |
val (sock, _)= Socket.accept passive_sock;
|
|
63 |
|
|
64 |
val (sin, sout) = SocketUtil.make_streams sock;
|
|
65 |
|
|
66 |
fun send msg = BinIO.output (sout, Byte.stringToBytes msg);
|
|
67 |
fun send_log msg = (tracing msg; send msg);
|
|
68 |
|
|
69 |
fun get_content (st, 0) = Word8Vector.fromList []
|
|
70 |
| get_content x = BinIO.inputN x;
|
|
71 |
|
|
72 |
fun do_req () =
|
|
73 |
let
|
|
74 |
val (req as ScgiReq.Req {path_info, request_method, ...},
|
|
75 |
content_is) =
|
|
76 |
ScgiReq.parse sin
|
|
77 |
handle ScgiReq.InvalidReq s =>
|
|
78 |
(send
|
|
79 |
(HttpUtil.reply_header (HttpStatus.bad_request, NONE, []));
|
|
80 |
raise Fail ("Invalid request: " ^ s));
|
|
81 |
val () = tracing ("request: " ^ path_info);
|
|
82 |
in
|
|
83 |
(case lookup (unprefix server_prefix path_info) of
|
|
84 |
NONE => send (HttpUtil.reply_header (HttpStatus.not_found, NONE, []))
|
|
85 |
| SOME (NONE, f) => f (req, get_content content_is, send)
|
|
86 |
| SOME (t, f) =>
|
|
87 |
(send (HttpUtil.reply_header (HttpStatus.ok, t, []));
|
|
88 |
if request_method = ScgiReq.Head then ()
|
|
89 |
else f (req, get_content content_is, send)))
|
|
90 |
end;
|
|
91 |
|
|
92 |
fun thread_req () =
|
|
93 |
(do_req () handle e => (warning (exnMessage e));
|
|
94 |
BinIO.closeOut sout handle e => warning (exnMessage e);
|
|
95 |
BinIO.closeIn sin handle e => warning (exnMessage e);
|
|
96 |
Socket.close sock handle e => warning (exnMessage e);
|
|
97 |
tracing ("request done.");
|
|
98 |
ConditionVar.signal thread_wait);
|
|
99 |
in
|
|
100 |
launch_thread thread_req;
|
|
101 |
loop ()
|
|
102 |
end;
|
|
103 |
in
|
|
104 |
tracing ("SCGI server started.");
|
|
105 |
dump_handlers ();
|
|
106 |
loop ();
|
|
107 |
Socket.close passive_sock
|
|
108 |
end;
|
|
109 |
|
|
110 |
local
|
|
111 |
val delay = 5;
|
|
112 |
in
|
|
113 |
fun server' 0 server_prefix port = (warning "Giving up."; exit 1)
|
|
114 |
| server' countdown server_prefix port =
|
|
115 |
server server_prefix port
|
|
116 |
handle OS.SysErr ("bind failed", _) =>
|
|
117 |
(warning ("Could not acquire port "
|
|
118 |
^ Int.toString port ^ ". Trying again in "
|
|
119 |
^ Int.toString delay ^ " seconds...");
|
|
120 |
OS.Process.sleep (Time.fromSeconds delay);
|
|
121 |
server' (countdown - 1) server_prefix port);
|
|
122 |
end;
|
|
123 |
|
|
124 |
end;
|
|
125 |
|