From: Stefano Zacchiroli <zack@upsilon.cc>
Date: Thu, 20 May 2004 14:30:27 +0000 (+0000)
Subject: - added support for HTTP (Basic) authentication
X-Git-Tag: V_0_0_9~30
X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=b8bc44da2bce663e58a85dd2e4c46fe8db700471;p=helm.git

- added support for HTTP (Basic) authentication
- simplified usage of some internal optional parameters
---

diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml
index 9e0507dd2..61c2ded23 100644
--- a/helm/DEVEL/ocaml-http/http_daemon.ml
+++ b/helm/DEVEL/ocaml-http/http_daemon.ml
@@ -96,17 +96,16 @@ let foo_body code body =
   of an HTTP response; body, if given, will be appended to the body *)
 let send_foo_body code body = send_raw ~data:(foo_body code body)
 
-let respond
   (* Warning: keep default values in sync with Http_response.response class *)
-  ?(body = "") ?(headers = [])
-  ?(version = http_version) ?(code = 200) ?status outchan
+let respond
+  ?(body = "") ?(headers = []) ?version ?(code = 200) ?status outchan
   =
   let code =
     match status with
     | None -> code
     | Some s -> code_of_status s
   in
-  send_basic_headers ~version ~code outchan;
+  send_basic_headers ?version ~code outchan;
   send_headers ~headers outchan;
   send_header "Content-Length" (string_of_int (String.length body)) outchan;
   send_CRLF outchan;
@@ -118,8 +117,8 @@ let respond
   reason phrase; if body is given it will be included in the body of the HTML
   page *)
 let send_empty_response
-  func_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () =
-    fun ?(version = http_version) ?code ?status outchan ->
+  func_name ?(is_valid_status = fun _ -> true) ?(headers=[]) ?(body="") () =
+    fun ?version ?code ?status outchan ->
       let code = get_code_argument func_name ~code ~status in
       if not (is_valid_status code) then
         failwith
@@ -132,23 +131,11 @@ let send_empty_response
           ] @ headers
         in
         let body = (foo_body code body) ^ body in
-        respond ~version ~code ~headers ~body outchan
-(*
-        (* OLD VERSION, now use 'respond' function *)
-        send_basic_headers ~version ~code outchan;
-        send_header ~header:"Connection" ~value:"close" outchan;
-        send_header
-          ~header:"Content-Type"
-          ~value:"text/html; charset=iso-8859-1"
-          outchan;
-        send_headers ~headers outchan;
-        send_CRLF outchan;
-        send_foo_body ~code ~body outchan
-*)
+        respond ?version ~code ~headers ~body outchan
       end
 
 let respond_redirect
-  ~location ?(body = "") ?(version = http_version) ?(code = 301) ?status outchan
+  ~location ?body ?version ?(code = 301) ?status outchan
   =
   let code = 
     match status with
@@ -157,43 +144,35 @@ let respond_redirect
   in
   send_empty_response
     "Daemon.respond_redirect" ~is_valid_status:is_redirection
-    ~headers:["Location", location] ~body ()
-    ~version ~code outchan
-
-let respond_error
-  ?(body = "") ?(version = http_version) ?(code = 400) ?status outchan =
-    let code =
-      match status with
-      | None -> code
-      | Some s -> code_of_status s
-    in
-    send_empty_response
-      "Daemon.respond_error" ~is_valid_status:is_error ~body ()
-      ~version ~code outchan
-
-let respond_not_found ~url ?(version = http_version) outchan =
+    ~headers:["Location", location] ?body ()
+    ?version ~code outchan
+
+let respond_error ?body ?version ?(code = 400) ?status outchan =
+  let code =
+    match status with
+    | None -> code
+    | Some s -> code_of_status s
+  in
   send_empty_response
-    "Daemon.respond_not_found" ~body:"" () ~version ~code:404 outchan
+    "Daemon.respond_error" ~is_valid_status:is_error ?body () ?version ~code
+    outchan
+
+let respond_not_found ~url ?version outchan =
+  send_empty_response
+    "Daemon.respond_not_found" () ?version ~code:404 outchan
 
-let respond_forbidden ~url ?(version = http_version) outchan =
+let respond_forbidden ~url ?version outchan =
   send_empty_response
-    "Daemon.respond_permission_denied" ~body:"" () ~version ~code:403 outchan
+    "Daemon.respond_permission_denied" () ?version ~code:403 outchan
+
+let respond_unauthorized ?version ?(realm = server_string) outchan =
+  respond ~headers:["WWW-Authenticate", sprintf "Basic realm=\"%s\"" realm]
+    ~code:401 outchan
 
-(* let send_file ?name ?file outchan = *)
 let send_file ~src outchan =
   let buflen = 1024 in
   let buf = String.make buflen ' ' in
-(*
-  let (file, cleanup) =
-    (match (name, file) with
-    | Some n, None -> (* if we open the file, we close it before returning *)
-        let f = open_in n in
-        f, (fun () -> close_in f)
-    | None, Some f -> (f, (fun () -> ()))
-    | _ ->  (* TODO use some static type checking *)
-        failwith "Daemon.send_file: either name or file must be given")
-  in
-*)
+
   let (file, cleanup) =
     match src with
     | FileSrc fname -> (* if we open the file, we close it before returning *)
@@ -378,7 +357,9 @@ let start
       let (path, parameters) = safe_parse_request inchan outchan in
       callback path parameters outchan;
       flush outchan
-    with Again -> ()
+    with
+    | Unauthorized realm -> respond_unauthorized ~realm outchan
+    | Again -> ()
   in
   try
     (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
@@ -396,7 +377,9 @@ let start'
       let req = safe_parse_request' inchan outchan in
       callback req outchan;
       flush outchan
-    with Again -> ()
+    with
+    | Unauthorized realm -> respond_unauthorized ~realm outchan
+    | Again -> ()
   in
   try
     (server_of_mode mode) ~sockaddr ~timeout daemon_callback