(* Compilieren mit:
   ocamlc -o httpserver str.cma unix.cma httpserver.ml
   *)

(* Konfiguration des HTTP-Servers *)

let document_root = "." (* aktuelles Verzeichnis *)
let redirections =
  [ "/geheim/", "/topsecret/" ]

(* Some code for parsing a request-line -- Aufgabe 1 *)

open Str

type httpMethod =
    OPTIONS
  | GET
  | HEAD
  | POST
  | PUT
  | DELETE
  | TRACE
  | CONNECT
  | ExtensionMethod of string

let httpMethod_of_string s =
  if s = "OPTIONS" then OPTIONS
  else if s = "GET" then GET
  else if s = "HEAD" then HEAD
  else if s = "POST" then POST
  else if s = "PUT" then PUT
  else if s = "DELETE" then DELETE
  else if s = "TRACE" then TRACE
  else if s = "CONNECT" then CONNECT
  else ExtensionMethod s

type httpVersion = int * int (* major, minor *)

type requestLine = {
  rl_method : httpMethod;
  rl_uri : string;
  rl_version: httpVersion;
}

exception BadRequest

let httpVersion_of_string majors minors =
  try
    (int_of_string majors), (int_of_string minors)
  with
      Failure _ -> raise BadRequest

let convert_pchars s =
  let htoi h =
    match (int_of_char h) with
	i when (i >= 48) && (i <= 57) -> i - 48
      | i when (i >= 97) && (i <= 102) -> i - 87
      | i when (i >= 65) && (i <= 70) -> i - 55
      | _ -> raise (Invalid_argument "htoi") in
  let convert c1 c2 =
    char_of_int ((16 * (htoi c1)) + (htoi c2)) in
  let rec loop i res =
    if i < String.length s then
      if s.[i] = '%' then
	if (i+2) < (String.length s) then
	  let c = (try convert s.[i+1] s.[i+2]
		   with Invalid_argument _ -> raise BadRequest) in
	    loop (i+3) (res^(String.make 1 c))
	else raise BadRequest
      else loop (i+1) (res^(String.make 1 s.[i]))
    else res
  in
    loop 0 ""

let requestLine_of_string s =
  let r = regexp "^\\([^ ]+\\) \\(/[^ ]*\\) HTTP/\\([0-9]+\\)\\.\\([0-9]+\\)$"
  in
    if string_match r s 0 then
      { rl_method = httpMethod_of_string (matched_group 1 s);
	rl_uri = matched_group 2 s;
	rl_version = (httpVersion_of_string (matched_group 3 s)
			(matched_group 4 s)); }
    else
      raise BadRequest

(* Utils *)

let read_line inch =
  let rec loop res =
    let c = input_char inch in
    let res = res ^ (String.make 1 c) in
    let res_len = String.length res in
      if (res_len >= 2) && ((String.sub res (res_len-2) 2) = "\r\n")
      then String.sub res 0 (res_len - 2)
      else loop res
  in
    loop ""

(* Server *)

(* Read lines until an empty line, and return them as a list *)
let read_headers inch =
  let rec loop rev_res =
    let s = read_line inch in
      if s = ""
      then List.rev rev_res
      else loop (s::rev_res)
  in
    loop []

(* Send all content of inch to outch *)
let output_channel outch inch =
  let n = 1024 in
  let buf = String.create n in
  let rec loop () =
    let r = input inch buf 0 n in
      output outch buf 0 r;
      flush outch;
      if r <> 0
      then loop ()
  in
    loop ()

(* Put a HTTP-Reply with no headers into the buffer and return None *)
let simple_reply buffer sc reason =
  Buffer.add_string buffer ("HTTP/1.1 "^(string_of_int sc)^" "^reason^"\r\n");
  Buffer.add_string buffer "\r\n";
  None

(* Return a MIME-Type for the file named by fname *)
let get_mime_type fname =
  let (inch, outch) = Unix.open_process ("file -i \""^fname^"\" 2>/dev/null") in
  let s = input_line inch in
  let r = regexp ".*: \\(.*\\)" in
    if string_match r s 0 then
      matched_group 1 s
    else raise (Failure "get_mime_type")

(* Look trough all known redirections. If one matches, then put a 301
   Message in the buffer and return true, return false otherwise. *)
let handle_redirections send_content buffer uri =
  let urilen = String.length uri in
  let rec loop rs =
    match rs with
	[] -> false
      | (froms, tos)::rs ->
	  let len = String.length froms in
	    if (len <= urilen) && (froms = (String.sub uri 0 len)) then
	      let new_uri = tos^(Str.string_after uri len) in
		Buffer.add_string buffer "HTTP/1.1 301 Moved Permanently\r\n";
		Buffer.add_string buffer ("Location: "^new_uri^"\r\n");
		Buffer.add_string buffer "\r\n";
		true
	    else
	      loop rs
  in
    loop redirections

(* Handles a GET or HEAD request. Puts the header into the buffer, and
   returns Some in_channel that contains the rest of the reply, if
   send_content is true, and None otherwise *)
let generic_handle_get_request send_content buffer uri =
  if not (handle_redirections send_content buffer uri) then
    let fname = document_root^uri in
    let exis = Sys.file_exists fname in
    let acc = exis && (try Unix.access fname [Unix.R_OK]; true
		       with _ -> false) in
      match exis, acc with
	  true, true ->
	    let mime_type = get_mime_type fname in
	    let file_len = string_of_int ((Unix.stat fname).Unix.st_size) in
	      Buffer.add_string buffer "HTTP/1.1 200 OK\r\n";
	      Buffer.add_string buffer ("Content-type: "^mime_type^"\r\n");
	      Buffer.add_string buffer ("Content-length: "^file_len^"\r\n");
	      Buffer.add_string buffer "\r\n";
	      if send_content then
		Some (open_in_gen [Open_rdonly; Open_binary] 0o004 fname)
	      else
		None
	| true, false ->
	    simple_reply buffer 403 "Forbidden"
	| false, _ ->
	    simple_reply buffer 404 "Not Found"
  else
    None

let handle_get_request = generic_handle_get_request true  
let handle_head_request = generic_handle_get_request false

(* Function that handles a client connected over the in_channel and
   out_channel *)

let server_proc inch outch =
  let buffer = Buffer.create 1024 in (* an extensible string buffer for
					the short parts of a reply *)
  let file_o = (* and an optional in_channel for longer parts *)
    try begin
      let s = read_line inch in
      let headers = read_headers inch in
	(* write headers to standard output *)
	List.iter print_endline headers;
	(* parse the request-line and take a look at it *)
	match requestLine_of_string s with
	    { rl_method = m; rl_uri = uri; rl_version = v } -> begin
	      match v with
		  (1,1) -> begin
		    match m with
			(* only GET and HEAD methods are supported *)
			GET -> handle_get_request buffer uri
		      | HEAD -> handle_head_request buffer uri
		      | _ -> simple_reply buffer 501 "Not Implemented"
		  end
		| _ -> simple_reply buffer 505 "HTTP Version not supported"
	    end
    end
    with 
	BadRequest -> simple_reply buffer 400 "Bad Request"
	  (* BadRequest is raised, if the parsing fails *)
      | End_of_file -> Buffer.reset buffer; None
	  (* The client closed the connection unexpectedly. Make sure nothing
	     is sent back now *)
      | other ->
	  (* Other exception have to be seen as Internal Server Error *)
	  (* If some output had been created already, delete it *)
	  Buffer.reset buffer;
	  simple_reply buffer 500 "Internal Server Error"
  in
    (* send everything back *)
    Buffer.output_buffer outch buffer;
    flush outch;
    match file_o with
	None -> ()
      | Some ch ->
	  output_channel outch ch;
	  flush outch;
	  close_in ch

(* Start the server *)

let start () =
  Unix.establish_server server_proc
    (Unix.ADDR_INET (Unix.inet_addr_any, 8080))

let _ =
  Unix.handle_unix_error start ()