Source

amall / src / amall_http_server.ml

open Amall_types;
open Am_Ops;
open Printf;
open Amall_http;

type port = int;
type addr_string = string;

type listen_addr =
  [= `Inet_any of port
  |  `Inet_loopback of port
  |  `Inet_str of (addr_string * port)
  |  `Inet_addr of (Unix.inet_addr * port)
  ]
;

module Http_server
  (IO : IO_Type)
  (I : It_type.IT with
        type It_IO.m 'a = IO.m 'a
    and type It_IO.input_channel = IO.input_channel
  )
 :
  sig

    type http_server_func = request -> I.iteratee char response
    ;


    value post_form : request ->
      I.iteratee char (request * list (string * string))
    ;

    value it_post_vars : I.iteratee char (list (string * string))
    ;


    value run : listen_addr -> http_server_func -> IO.server
    ;

  end
=
struct

module H = Amall_http.Make(IO)(I);

value it_post_vars = H.it_post_vars
;

open I.Ops;

type http_server_func = request -> I.iteratee char response
;

value (runA : IO.m (I.iteratee 'el 'a) -> It_Types.res 'a) i =
  IO.runIO (i >>% I.run)
;

value rec printexc e =
  match e with
  [ I.Iteratees_err_msg e -> printexc e
  | _ -> Printexc.to_string e
  ]
;

value rec dump_chars_chunks title =
  I.ie_cont step
  where rec step s =
  match s with
  [ I.EOF oe ->
      let err =
        match oe with
        [ None -> "eof"
        | Some e -> printexc e
        ]
      in
        IO.printf "dump_chars_chunks: %s: EOF: %s.\n" title err >>% fun () ->
        I.ie_doneM () s
  | I.Chunk c ->
      IO.printf "dump_chars_chunks: %s: Chunk: %S\n"
        title (I.Subarray.to_string c) >>% fun () ->
      I.ie_contM step
  ]
;



value (post_form : request ->
  I.iteratee char (request * list (string * string))
) request =
  I.printf "request headers was read ok, request_uri: %S, uri: %S.\n\
            headers:\n%s\n===\n%!"
       (Uri.dump_uri request.rq_request_uri__)
       ( (* Uri.dump_uri request.rq_uri *) "<todo>")
       (String.concat "\n" & List.map (fun (k,v) -> sprintf "%S = %S" k v)
         request.rq_headers.rq_all
       )
  >>= fun () ->
(*
  dump_chars_chunks "header"
*)
  H.request_with_post_vars request
;



value _ () =
  let fn = "post-req" in
  match
    runA & I.enum_file fn &
      ((H.it_http & post_form)
       >>= fun r -> dump_chars_chunks "after body" >>= fun () ->
       I.return r
      )
  with
  [ `Ok _ -> ()
  | `Error e -> eprintf "exception: %s\n%!" & printexc e
  ]
;


value () = ignore & I.limit;

(**********************************************************)


value dbg fmt = Printf.ksprintf (Printf.printf "hs: %s\n%!") fmt;


value http_server_func userfunc (inch, outch) =
  IO.run_and_ignore_result
     (IO.catch
        (fun () ->
           let do_close () =
             IO.close_in inch >>% fun () ->
             IO.close_out outch
           in
           let it_req = H.it_http userfunc in
           I.enumpart_readchars
             ~buffer_size:4096
             ~read_func:IO.read_into
             inch
             I.Sl.empty
             it_req
           >>% loop
           where rec loop (it, sl_l, opt_enp) =
             let () = dbg "hs: entered loop" in
             match opt_enp with
             [ I.EP_None -> do_close ()
             | I.EP_Some cont ->
                 let () = dbg "got cont" in

    match it with
    [ I.IE_cont (Some e) _ ->
      let () = dbg "cont: error %S" (Printexc.to_string e) in
      do_close ()
    | I.IE_cont None _ ->
        let () = dbg "cont: cont" in
        failwith "cont-cont1111"
    | I.IE_done it -> I.run it >>% fun (request, resp) ->
    let () = dbg "hsf: got req/resp" in

    let is_head = (request.rq_method = `HEAD) in
    H.output_response ~is_head outch resp >>% fun () ->

    let need_to_close =
      (List.mem `Close request.rq_headers.connection) ||
      (List.exists (fun (hk, hv) -> hk = "Connection" && hv = "close")
         resp.rs_headers.rs_all)
    in
      if need_to_close
      then
        do_close ()
      else
        IO.flush outch >>% fun () ->
        let sl = Lazy.force sl_l in
        cont sl it_req >>% loop


             ]
   ]
        )
        (fun e ->
          ( Printf.eprintf "amall http: exception: %s\n%!" &
              Printexc.to_string e
          ; IO.return ()
          )
        )
     )
;


value run_addr listen_addr userfunc =
  IO.establish_server listen_addr (http_server_func userfunc)
;


value run listen_addr userfunc =
  let a =
    match listen_addr with
    [ `Inet_any port -> Unix.ADDR_INET (Unix.inet_addr_any, port)
    | `Inet_loopback port -> Unix.ADDR_INET (Unix.inet_addr_loopback, port)
    | `Inet_str str port -> Unix.ADDR_INET (Unix.inet_addr_of_string str, port)
    | `Inet_addr a p -> Unix.ADDR_INET (a, p)
    ]
  in
    run_addr a userfunc
;


end;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.