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