(*** HTTP *)

open Unix;;
open Debug;;

let info = Log.info;;

type request =
| Get of string
and headers = (string * string) list
and response =
| Okay of content_type * byte_source
| Error of error * string
and error =
| Internal_server_error
| Document_not_found
| Forbidden
| Method_not_allowed
and content_type =
| Text_Html
| Text_Css
| Application_Octet_stream
and byte_source =
| Html of Html.html_document
| File of string
| String of string
;;

let string_of_content_type = function
| Text_Html -> "text/html"
| Text_Css -> "text/css"
| Application_Octet_stream -> "application/octet-stream"
;;

open Html;;

let error_document err str = 
  let code,title,msg =
    match err with
    | Internal_server_error ->
        500,
        "Internal server error",
        sf "The server encountered and internal error (%s)\
            and was unable to complete your request."
           str
    | Method_not_allowed ->
        405,
        "Method not allowed",
        sf "The method (%S) is not allowed." str
    | Document_not_found ->
        404,
        "Not found",
        sf "The document you requested (%S) could not be \
            located."
           str
    | Forbidden ->
        403,
        "Forbidden",
        sf "You are not allowed to access %S." str
  in
  code,
  title,
  { head =
      { default_head with
        title = title;
        author = "ARA HTTP Server";
        charset = ISO_8859_1 };
    body =
      Seq[
        H(1,T(title));
        P(T msg)] }
;;

let handler processor (fd,address) =
  let ic = in_channel_of_descr fd
  and oc = out_channel_of_descr fd
  and b = Buffer.create 16
  in
  let rec loop () =
    let (meth,url,vh,vl) =
    Scanf.sscanf (input_line ic) "%s %s HTTP/%d.%d\r" (fun meth url vh vl -> (meth,url,vh,vl))
    in
    let rec collect_headers r =
      match input_line ic with
      | "\r" -> r
      | l ->
          collect_headers ((Scanf.sscanf l "%s@: %s@\r" (fun f v -> (String.lowercase f,v)))::r)
    in
    let hdrs = collect_headers [] in
    List.iter (fun (x,y) -> Log.access (sf "Header: %s %S" x y)) hdrs;
    let keep_alive =
      try
        String.lowercase (List.assoc "connection" hdrs) = "keep-alive" (* XXX *)
      with
      | Not_found -> false
    in
    let connection_string =
      if keep_alive then
        "Keep-Alive"
      else
        "Close"
    in
    let output_html rh ct d =
      Html.output_to_buffer b d;
      Printf.fprintf oc "%s\r\n" rh;
      if ct = Text_Html then
        Printf.fprintf oc "Content-Type: text/html; charset=iso-8859-1\r\n" (* XXX *)
      else
        Printf.fprintf oc "Content-Type: %s\r\n" (string_of_content_type ct);
      Printf.fprintf oc "\
        Content-Length: %d\r\n\
        Connection: %s\r\n\
        \r\n"
        (Buffer.length b)
        connection_string;
      Buffer.output_buffer oc b;
      Buffer.clear b;
      flush oc
    in
    let do_error err str =
      let code,title,doc = error_document err str in
      Log.access (sf "ERROR %S %S" str title);
      output_html (sf "HTTP/1.1 %d %s" code title) Text_Html doc
      (* shutdown fd SHUTDOWN_ALL *)
    in
    begin
      match meth with
      | "GET" ->
          begin
            let result =
              try
                processor (Get url,hdrs)
              with
              | x ->
                  Error(Internal_server_error,
                        sf "An exception occurred: %s" (Printexc.to_string x))
            in
            let custom ct bs =
              match bs with
              | Html d ->
                  output_html "HTTP/1.1 200 Fine" ct d;
                  Log.access (sf "OK GET %S html" url)
              | String w ->
                  Printf.fprintf oc "HTTP/1.1 200 Fine\r\n\
                                     Content-Type: %s\r\n\
                                     Connection: %s\r\n\
                                     Content-Length: %d\r\n\
                                     \r\n"
                  (string_of_content_type ct)
                  connection_string
                  (String.length w);
                  output_string oc w;
                  flush oc;
                  Log.access (sf "OK GET %S string" url)
              | File fn ->
                  begin
                    try
                      let ic = open_in fn in
                      let m = 4096 in
                      let b = Buffer.create m in
                      let w = String.make m '\000' in
                      try
                        while true do
                          let n = input ic w 0 m in
                          if n  = 0 then
                            raise End_of_file
                          else
                            Buffer.add_substring b w 0 n
                        done;
                        assert false
                      with
                      | End_of_file ->
                          close_in ic;
                          Printf.fprintf oc "HTTP/1.1 200 Fine\r\n\
                                             Content-Type: %s\r\n\
                                             Connection: %s\r\n\
                                             Content-Length: %d\r\n\
                                             \r\n"
                                             (string_of_content_type ct)
                                             connection_string
                                             (Buffer.length b);
                          Buffer.output_buffer oc b;
                          flush oc;
                          Log.access (sf "OK GET %S file %S" url fn)
                    with
                    | x -> do_error Internal_server_error (Printexc.to_string x)
                  end
            in
            match result with
            | Okay(ct,bs) -> custom ct bs
                (* shutdown fd SHUTDOWN_ALL *)
            | Error(err,str) -> do_error err str
          end
      | _ -> do_error Method_not_allowed meth
    end;
    if keep_alive then
      loop ()
    else
      begin
        shutdown fd SHUTDOWN_ALL;
        close_out oc;
        Log.access "Closing connection";
        Thread.exit ()
      end
  in
  try
    loop ()
  with
  | End_of_file ->
      info "Remote end closed connection";
      shutdown fd SHUTDOWN_ALL;
      close_out oc;
      Thread.exit ()
;;
