[Pkg-ocaml-maint-commits] [SCM] approx upstream and debian packaging branch, upstream, updated. upstream/3.5-41-g482c98d

Wed Jun 23 18:47:05 UTC 2010

The following commit has been merged in the upstream branch:
commit 77f3ee0cca3936c103f44aea0b0b8fb903a0a10c
Author: Eric Cooper <ecc at cmu.edu>
Date:   Sun Jun 20 13:29:20 2010 -0400

    provide directory index for cache
    
    redirect requests for top levels of remote repositories
    
    closes: #577969

diff --git a/approx.ml b/approx.ml
index afb15b0..a210c42 100644
--- a/approx.ml
+++ b/approx.ml
@@ -425,18 +425,31 @@ let ims_time env =
 
 let server_error msg = `Std_response (`Internal_server_error, None, Some msg)
 
+let is_repository name =
+  try String.index name '/' = String.length name - 1
+  with Not_found -> true
+
+let redirect url =
+  debug_message "  => redirect to %s" url;
+  let header = new Netmime.basic_mime_header ["Location", url] in
+  `Std_response (`Temporary_redirect, Some header, None)
+
 let serve_file env =
   (* handle URL-encoded '+', '~', etc. *)
   let path = Netencoding.Url.decode ~plus: false env#cgi_request_uri in
-  try
-    let url, name = Url.translate_request path in
-    if should_pass_through name then cache_miss url name 0. 0.
-    else
-      let ims = ims_time env in
-      match serve_local name ims env with
-      | Done reaction -> reaction
-      | Cache_miss mod_time -> cache_miss url name ims mod_time
-  with Failure msg | Invalid_argument msg-> server_error msg
+  if path = "/" then
+    `Static (`Ok, None, Config.index)
+  else
+    try
+      let url, name = Url.translate_request path in
+      if is_repository name then redirect url
+      else if should_pass_through name then cache_miss url name 0. 0.
+      else
+        let ims = ims_time env in
+        match serve_local name ims env with
+        | Done reaction -> reaction
+        | Cache_miss mod_time -> cache_miss url name ims mod_time
+    with Failure msg | Invalid_argument msg-> server_error msg
 
 let process_header env =
   debug_message "Connection from %s"
diff --git a/config.ml b/config.ml
index aab3800..5ee4d69 100644
--- a/config.ml
+++ b/config.ml
@@ -40,3 +40,49 @@ let max_wait = get_int "$max_wait" ~default: 10 (* seconds *)
 
 let debug = get_bool "$debug" ~default: false
 let verbose = get_bool "$verbose" ~default: false || debug
+
+let collect k v (r, s) =
+  if k.[0] = '$' then r, (k, v) :: s
+  else (k, v) :: r, s
+
+let repositories, parameters = fold collect ([], [])
+
+let sort_config = List.sort (fun x y -> compare (fst x) (fst y))
+
+let repository_table =
+  String.concat "\n"
+    (List.map
+       (fun (k, v) ->
+          "<tr><td>" ^ k ^ "</td>\
+               <td><a href=\"" ^ v ^ "\">" ^ v ^ "</a></td></tr>")
+       (sort_config repositories))
+
+let parameter_table =
+  String.concat "\n"
+    (List.map
+       (fun (k, v) -> "<tr><td>" ^ k ^ "</td><td>" ^ v ^ "</td></tr>")
+       (sort_config parameters))
+
+let css =
+  "body { margin: 12pt }\n\
+   td { padding-left: 12pt }\n\
+   td h2 { padding-top: 18pt }\n"
+
+let index =
+  "<html>\n\
+     <head>\n\
+       <title>approx server</title>\n\
+       <style type=\"text/css\">\n" ^
+       css ^
+      "</style>\n\
+     </head>\n\
+     <body>\n\
+       <h1>approx " ^ version ^ "</h1>\n\
+       <table>\n\
+         <tr><td colspan=\"2\"><h2>Repository Mappings</h2></td></tr>\n" ^
+         repository_table ^
+        "<tr><td colspan=\"2\"><h2>Configuration Parameters</h2></td></tr>\n" ^
+         parameter_table ^
+      "</table>\n\
+     </body>\n\
+   </html>"
diff --git a/config.mli b/config.mli
index 917d59b..b71e24d 100644
--- a/config.mli
+++ b/config.mli
@@ -1,5 +1,5 @@
 (* approx: proxy server for Debian archive files
-   Copyright (C) 2009  Eric C. Cooper <ecc at cmu.edu>
+   Copyright (C) 2010  Eric C. Cooper <ecc at cmu.edu>
    Released under the GNU General Public License *)
 
 val version : string
@@ -30,3 +30,8 @@ val max_wait : int (* seconds *)
 
 val verbose : bool
 val debug : bool
+
+(* A simple HTML index for the server,
+   listing the repository mappings and configuration parameters *)
+
+val index : string

-- 
approx upstream and debian packaging

