[Pkg-ocaml-maint-commits] [SCM] approx upstream and debian packaging branch, lenny-backport, updated. debian/5.0-1_bpo50+1

Eric Cooper ecc at cmu.edu
Wed Jun 22 02:26:45 UTC 2011


The following commit has been merged in the lenny-backport branch:
commit d7dc25f8b52c80e2b45336087bb83a0c3f8ccde7
Author: Eric Cooper <ecc at cmu.edu>
Date:   Thu May 5 22:59:25 2011 -0400

    backport to lenny
    
    no backtrace functions in Printexc module
    
    use debhelper version 7, not 8
    
    no dh-ocaml

diff --git a/approx.ml b/approx.ml
deleted file mode 100644
index cfff465..0000000
--- a/approx.ml
+++ /dev/null
@@ -1,594 +0,0 @@
-(* approx: proxy server for Debian archive files
-   Copyright (C) 2011  Eric C. Cooper <ecc at cmu.edu>
-   Released under the GNU General Public License *)
-
-open Printf
-open Unix
-open Unix.LargeFile
-
-open Config
-open Log
-open Program
-open Util
-
-(* Hint that a download is in progress *)
-
-let in_progress name = name ^ ".hint"
-
-let wait_for_download_in_progress name =
-  let hint = in_progress name in
-  let timeout = float_of_int max_wait in
-  let rec wait n =
-    match stat_file hint with
-    | Some { st_mtime = mtime } ->
-        if time () -. mtime > timeout then begin
-          error_message "Concurrent download of %s is taking too long" name;
-          (* remove the other process's hint file if it still exists,
-             so we can create our own *)
-          rm hint
-        end else begin
-          if n = 0 then
-            debug_message "Waiting for concurrent download of %s" name;
-          sleep 1;
-          wait (n + 1)
-        end
-    | None -> ()
-  in
-  wait 0
-
-let debug_headers msg headers =
-  debug_message "%s" msg;
-  List.iter (fun (x, y) -> debug_message "  %s: %s" x y) headers
-
-let proxy_headers size modtime =
-  let headers =
-    ["Content-Type", "text/plain";
-     "Content-Length", Int64.to_string size]
-  in
-  if modtime = 0. then headers
-  else ("Last-Modified", Url.string_of_time modtime) :: headers
-
-type local_status =
-  | Done of Nethttpd_types.http_service_reaction
-  | Cache_miss of float
-
-let head_request env = env#cgi_request_method = "HEAD"
-
-(* Deliver a file from the local cache *)
-
-let deliver_local name env =
-  debug_message "  => delivering from cache";
-  let size = file_size name in
-  env#set_output_header_fields (proxy_headers size (file_modtime name));
-  debug_headers "Local response" env#output_header_fields;
-  let file = if head_request env then "/dev/null" else cache_dir ^/ name in
-  Done (`File (`Ok, None, file, 0L, size))
-
-let not_modified () =
-  debug_message "  => not modified";
-  Done (`Std_response (`Not_modified, None, None))
-
-let nak () =
-  debug_message "  => not found (cached)";
-  Done (`Std_response (`Not_found, None, None))
-
-(* The modification time (mtime) tells when the contents of the file
-   last changed, and is used by the "If-Modified-Since" logic.
-
-   The last status change time (ctime) is used to indicate when a file
-   was last "verified" by contacting the remote repository.
-
-   Whenever we learn that the file is still valid via a "Not Modified"
-   response, we update the ctime so that the file will continue to be
-   considered current. *)
-
-let print_age mod_time ctime =
-  if debug then begin
-    debug_message "  last modified: %s" (Url.string_of_time mod_time);
-    debug_message "  last verified: %s" (Url.string_of_time ctime)
-  end
-
-(* "File not found" or NAK responses are cached as empty files with
-   permissions = 0. Create a cached NAK as an empty temp file, set
-   its permissions, then atomically rename it. *)
-
-let cache_nak file =
-  debug_message "  caching \"file not found\"";
-  make_directory (Filename.dirname file);
-  let tmp_file = gensym file in
-  let chan = open_out_excl tmp_file in
-  close_out chan;
-  Unix.chmod tmp_file 0;
-  Sys.rename tmp_file file
-
-(* Attempt to serve the requested file from the local cache.
-   Deliver immutable files and valid index files from the cache.
-   Deliver Release files if they are not too old.
-   Otherwise contact the remote repository. *)
-
-let serve_local name ims env =
-  wait_for_download_in_progress name;
-  match stat_file name with
-  | Some { st_mtime = mod_time; st_ctime = ctime;
-           st_size = size; st_perm = perm } ->
-      let deliver_if_newer () =
-        if mod_time > ims then deliver_local name env
-        else not_modified ()
-      in
-      if size = 0L && perm = 0 then begin (* cached NAK *)
-        debug_message "  cached \"file not found\"";
-        print_age mod_time ctime;
-        if minutes_old ctime <= interval then nak ()
-        else Cache_miss mod_time
-      end else if Release.is_release name then begin
-        print_age mod_time ctime;
-        if minutes_old ctime <= interval then deliver_if_newer ()
-        else Cache_miss mod_time
-      end else if Release.immutable name || Release.valid name then
-        deliver_if_newer ()
-      else
-        Cache_miss 0.
-  | None ->
-      Cache_miss 0.
-
-let create_hint name =
-  make_directory (Filename.dirname name);
-  close (openfile (in_progress name) [O_CREAT; O_WRONLY] 0o644)
-
-let remove_hint name = rm (in_progress name)
-
-type cache_info = { file : string; tmp_file : string; chan : out_channel }
-
-type cache_state =
-  | Cache of cache_info
-  | Pass_through
-  | Undefined
-
-(* Don't cache the result of a request for a directory *)
-
-let should_pass_through name =
-  if Sys.file_exists name then Sys.is_directory name
-  else
-    let n = String.length name in
-    n = 0 || name.[n - 1] = '/' || not (String.contains name '/')
-
-let open_cache file =
-  if should_pass_through file then begin
-    debug_message "  pass-through %s" file;
-    Pass_through
-  end else
-    try
-      debug_message "  open cache %s" file;
-      make_directory (Filename.dirname file);
-      let tmp_file = gensym file in
-      let chan = open_out_excl tmp_file in
-      Cache { file = file; tmp_file = tmp_file; chan = chan }
-    with e ->
-      error_message "Cannot cache %s" file;
-      raise e
-
-let write_cache cache str pos len =
-  match cache with
-  | Cache { chan = chan } -> output chan str pos len
-  | Pass_through -> ()
-  | Undefined -> assert false
-
-exception Wrong_size
-
-let close_cache cache size mod_time =
-  match cache with
-  | Cache { file = file; tmp_file = tmp_file; chan = chan } ->
-      debug_message "  close cache %s" file;
-      close_out chan;
-      if size = file_size tmp_file then begin
-        if mod_time <> 0. then begin
-          debug_message "  setting mtime to %s" (Url.string_of_time mod_time);
-          utimes tmp_file mod_time mod_time
-        end;
-        Sys.rename tmp_file file
-      end else begin
-        error_message "Size of %s should be %Ld, not %Ld"
-          file size (file_size tmp_file);
-        rm tmp_file;
-        raise Wrong_size
-      end
-  | Pass_through -> ()
-  | Undefined -> assert false
-
-let remove_cache cache =
-  match cache with
-  | Cache { tmp_file = tmp_file; chan = chan } ->
-      close_out chan;
-      error_message "Removing %s (size: %Ld)" tmp_file (file_size tmp_file);
-      rm tmp_file
-  | Pass_through | Undefined -> ()
-
-type download_status =
-  | Delivered
-  | Cached
-  | Not_modified
-  | Redirect of string
-  | File_not_found
-
-let string_of_download_status = function
-  | Delivered -> "delivered"
-  | Cached -> "cached"
-  | Not_modified -> "not modified"
-  | Redirect url -> "redirected to " ^ url
-  | File_not_found -> "not found"
-
-type response_state =
-  { name : string;
-    mutable status : int;
-    mutable length : int64;
-    mutable last_modified : float;
-    mutable location : string;
-    mutable content_type : string;
-    mutable body_seen : bool;
-    mutable cache : cache_state }
-
-let new_response url name =
-  { name = name;
-    status = 0;
-    length = -1L;
-    last_modified = 0.;
-    location = url;
-    content_type = "text/plain";
-    body_seen = false;
-    cache = Undefined }
-
-type cgi = Netcgi1_compat.Netcgi_types.cgi_activation
-
-let send_header size modtime (cgi : cgi) =
-  let headers = proxy_headers size modtime in
-  let fields = List.map (fun (name, value) -> (name, [value])) headers in
-  cgi#set_header ~status: `Ok ~fields ();
-  debug_headers "Proxy response" cgi#environment#output_header_fields
-
-let pass_through_header resp (cgi : cgi) =
-  let fields = ["Content-Type", [resp.content_type]] in
-  let fields =
-    if resp.length < 0L then fields
-    else ("Content-Length", [Int64.to_string resp.length]) :: fields
-  in
-  cgi#set_header ~status: `Ok ~fields ();
-  debug_headers "Pass-through response" cgi#environment#output_header_fields
-
-let finish_delivery resp =
-  close_cache resp.cache resp.length resp.last_modified;
-  if resp.length >= 0L or resp.cache = Pass_through then Delivered else Cached
-
-let finish_head resp cgi =
-  send_header resp.length resp.last_modified cgi;
-  Delivered
-
-let with_pair rex str proc =
-  match Pcre.extract ~rex ~full_match: false str with
-  | [| a; b |] -> proc (a, b)
-  | _ -> assert false
-
-let status_re = Pcre.regexp "^HTTP/\\d+\\.\\d+\\s+(\\d{3})\\s+(.*?)\\s*$"
-let header_re = Pcre.regexp "^(.*?):\\s*(.*?)\\s*$"
-
-let process_header resp str =
-  let do_status (code, _) =
-    resp.status <- int_of_string code
-  in
-  let do_header (header, value) =
-    match String.lowercase header with
-    | "content-length" ->
-        (try resp.length <- Int64.of_string value
-         with Failure _ ->
-           error_message "Cannot parse Content-Length %s" value)
-    | "last-modified" ->
-        (try resp.last_modified <- Url.time_of_string value
-         with Invalid_argument _ ->
-           error_message "Cannot parse Last-Modified date %s" value)
-    | "location" ->
-        (try resp.location <- Neturl.string_of_url (Neturl.parse_url value)
-         with Neturl.Malformed_URL ->
-           error_message "Cannot parse Location %s" value)
-    | "content-type" -> (* only used for pass-through content *)
-        resp.content_type <- value
-    | _ -> ()
-  in
-  debug_message "  %s" str;
-  try with_pair header_re str do_header
-  with Not_found -> (* e.g., status line or CRLF *)
-    try with_pair status_re str do_status
-    with Not_found -> error_message "Unrecognized response: %s" str
-
-(* Process a chunk of the response body.
-   If no Content-Length was present in the header, we cache the whole
-   file before delivering it to the client. The alternative -- using
-   chunked transfer encoding -- triggers a bug in APT. *)
-
-let process_body resp cgi str pos len =
-  if resp.status = 200 then begin
-    if not resp.body_seen then begin
-      resp.body_seen <- true;
-      assert (resp.cache = Undefined);
-      resp.cache <- open_cache resp.name;
-      if resp.cache = Pass_through then
-        pass_through_header resp cgi
-      else if resp.length >= 0L then
-        send_header resp.length resp.last_modified cgi
-    end;
-    write_cache resp.cache str pos len;
-    if resp.length >= 0L || resp.cache = Pass_through then
-      (* stream the data back to the client as we receive it *)
-      cgi#output#really_output str pos len
-  end
-
-(* Download a file from an HTTP or HTTPS repository *)
-
-let download_http resp url name ims cgi =
-  let headers =
-    if ims > 0. then ["If-Modified-Since: " ^ Url.string_of_time ims] else []
-  in
-  let header_callback = process_header resp in
-  let body_callback = process_body resp cgi in
-  let is_head = head_request cgi#environment in
-  let rec loop redirects =
-    resp.status <- 0;
-    if is_head then
-      Url.head url header_callback
-    else
-      Url.download resp.location ~headers ~header_callback body_callback;
-    match resp.status with
-    | 200 -> if is_head then finish_head resp cgi else finish_delivery resp
-    | 304 -> Not_modified
-    | 301 | 302 | 303 | 307 ->
-        if should_pass_through (relative_url resp.location) then begin
-          (* the request was redirected to content that should not be cached,
-             like a directory listing *)
-          remove_cache resp.cache;
-          Redirect resp.location
-        end else if redirects >= max_redirects then begin
-          error_message "Too many redirections for %s" url;
-          File_not_found
-        end else
-          loop (redirects + 1)
-    | 404 -> File_not_found
-    | n -> error_message "Unexpected status code: %d" n; File_not_found
-  in
-  loop 0
-
-(* Download a file from an FTP repository *)
-
-let download_ftp resp url name ims cgi =
-  Url.head url (process_header resp);
-  let mod_time = resp.last_modified in
-  debug_message "  ims %s  mtime %s"
-    (Url.string_of_time ims) (Url.string_of_time mod_time);
-  if 0. < mod_time && mod_time <= ims then Not_modified
-  else if head_request cgi#environment then finish_head resp cgi
-  else begin
-    resp.status <- 200; (* for process_body *)
-    Url.download url (process_body resp cgi);
-    finish_delivery resp
-  end
-
-let download_url url name ims cgi =
-  let dl =
-    match Url.protocol url with
-    | Url.HTTP | Url.HTTPS -> download_http
-    | Url.FTP | Url.FILE -> download_ftp
-  in
-  let resp = new_response url name in
-  try
-    create_hint name;
-    unwind_protect
-      (fun () -> dl resp url name ims cgi)
-      (fun () -> remove_hint name)
-  with e ->
-    remove_cache resp.cache;
-    if e <> Failure url then info_message "%s" (string_of_exception e);
-    File_not_found
-
-(* Handle any processing triggered by downloading a given file *)
-
-let updates_needed = ref []
-
-let cleanup_after url file =
-  if pdiffs && Release.is_pdiff file then
-    (* record the affected index for later update *)
-    let index = Pdiff.index_file file in
-    if not (List.mem index !updates_needed) then begin
-      debug_message "Deferring pdiffs for %s" index;
-      updates_needed := index :: !updates_needed
-    end
-
-let copy_to dst src =
-  let len = 4096 in
-  let buf = String.create len in
-  let rec loop () =
-    match input src buf 0 len with
-    | 0 -> ()
-    | n -> dst#really_output buf 0 n; loop ()
-  in
-  loop ()
-
-(* Similar to deliver_local, but we have to copy it ourselves *)
-
-let copy_from_cache name cgi =
-  wait_for_download_in_progress name;
-  send_header (file_size name) (file_modtime name) cgi;
-  let output = cgi#output in
-  if not (head_request cgi#environment) then
-    with_in_channel open_in name (copy_to output);
-  output#commit_work ()
-
-(* Update the ctime but not the mtime of the file *)
-
-let update_ctime name =
-  match stat_file name with
-  | Some stats ->
-      utimes name stats.st_atime stats.st_mtime;
-      if debug then
-        let ctime = (stat name).st_ctime in
-        debug_message "  updated ctime to %s" (Url.string_of_time ctime)
-  | None -> ()
-
-let redirect url (cgi : cgi) =
-  let url' =
-    try
-      let path = Url.reverse_translate url in
-      cgi#url ~with_script_name: `None ~with_path_info: (`This path) ()
-    with Not_found -> url
-  in
-  new Netmime.basic_mime_header ["Location", url']
-
-let serve_remote url name ims mod_time cgi =
-  let respond ?header code =
-    raise (Nethttpd_types.Standard_response (code, header, None))
-  in
-  let copy_if_newer () =
-    (* deliver the cached copy if it is newer than the client's *)
-    if mod_time > ims then copy_from_cache name cgi
-    else respond `Not_modified
-  in
-  let status = download_url url name (max ims mod_time) cgi in
-  info_message "%s: %s" url (string_of_download_status status);
-  match status with
-  | Delivered ->
-      cgi#output#commit_work ();
-      if not (head_request cgi#environment) then cleanup_after url name
-  | Cached ->
-      copy_from_cache name cgi;
-      cleanup_after url name
-  | Not_modified ->
-      update_ctime name;
-      copy_if_newer ()
-  | Redirect url' ->
-      respond `Found ~header: (redirect url' cgi)
-  | File_not_found ->
-      if is_cached_nak name then begin
-        update_ctime name;
-        respond `Not_found
-      end else if offline && Sys.file_exists name then copy_if_newer ()
-      else begin
-        cache_nak name;
-        respond `Not_found
-      end
-
-let remote_service url name ims mod_time =
-  object
-    method process_body _ =
-      object
-        method generate_response env =
-          let cgi =
-            (* buffered activation runs out of memory on large downloads *)
-            Nethttpd_services.std_activation `Std_activation_unbuffered env
-          in
-          serve_remote url name ims mod_time cgi
-      end
-  end
-
-(* Handle a cache miss, either because the file is not present (mod_time = 0)
-   or it hasn't been verified recently enough *)
-
-let cache_miss url name ims mod_time =
-  debug_message "  => cache miss";
-  `Accept_body (remote_service url name ims mod_time)
-
-(* See if the given file should be denied (reported to the client as
-   not found) rather than fetched remotely. This is done in two cases:
-     * the client is requesting a non-gzipped version of an index
-     * the client is requesting a DiffIndex and an up-to-date .gz version
-       of the corresponding index exists in the cache
-   By denying the request, the client will fall back to requesting
-   the Packages.gz or Sources.gz file. Using .gz instead of .bz2
-   or other compressed formats allows pdiffs to be applied more quickly. *)
-
-let should_deny name =
-  (Release.is_index name && extension name <> ".gz") ||
-  (pdiffs && Release.is_diff_index name &&
-     Release.valid (Pdiff.index_file name))
-
-let deny name =
-  debug_message "Denying %s" name;
-  `Std_response (`Not_found, None, None)
-
-let ims_time env =
-  try Netdate.parse_epoch (env#input_header#field "If-Modified-Since")
-  with Not_found | Invalid_argument _ -> 0.
-
-let server_error e =
-  backtrace ();
-  `Std_response (`Internal_server_error, None, Some (string_of_exception e))
-
-let serve_file env =
-  (* handle URL-encoded '+', '~', etc. *)
-  let path = Netencoding.Url.decode ~plus: false env#cgi_request_uri in
-  if path = "/" then
-    `Static (`Ok, None, if head_request env then "" else Config.index)
-  else
-    try
-      let url, name = Url.translate_request path in
-      if should_pass_through name then cache_miss url name 0. 0.
-      else if should_deny name then deny name
-      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
-    | Not_found -> `Std_response (`Not_found, None, None)
-    | e -> server_error e
-
-let process_request env =
-  debug_message "Connection from %s"
-    (string_of_sockaddr env#remote_socket_addr ~with_port: true);
-  let meth = env#cgi_request_method in
-  debug_headers (sprintf "Request: %s %s" meth env#cgi_request_uri)
-    env#input_header_fields;
-  if (meth = "GET" || meth = "HEAD") && env#cgi_query_string = "" then
-    serve_file env
-  else
-    `Std_response (`Forbidden, None, Some "invalid HTTP request")
-
-let error_response code =
-  let msg =
-    try Nethttp.string_of_http_status (Nethttp.http_status_of_int code)
-    with Not_found -> "???"
-  in
-  sprintf "<html><title>%d %s</title><body><h1>%d: %s</h1></body></html>"
-    code msg code msg
-
-let config =
-  object
-    (* http_protocol_config *)
-    method config_max_reqline_length = 256
-    method config_max_header_length = 32768
-    method config_max_trailer_length = 32768
-    method config_limit_pipeline_length = 5
-    method config_limit_pipeline_size = 250000
-    method config_announce_server = `Ocamlnet_and ("approx/" ^ version)
-    (* http_processor_config *)
-    method config_timeout_next_request = 15.
-    method config_timeout = 300.
-    method config_cgi = Netcgi1_compat.Netcgi_env.default_config
-    method config_error_response n = error_response n
-    method config_log_error _ _ _ _ msg = error_message "%s" msg
-    (* http_reactor_config *)
-    method config_reactor_synch = `Write
-  end
-
-let proxy_service =
-  object
-    method name = "proxy_service"
-    method def_term = `Proxy_service
-    method print fmt = Format.fprintf fmt "%s" "proxy_service"
-    method process_header = process_request
-  end
-
-let approx () =
-  log_to_syslog ();
-  check_id ~user ~group;
-  Sys.chdir cache_dir;
-  set_nonblock stdin;
-  Nethttpd_reactor.process_connection config stdin proxy_service;
-  List.iter Pdiff.update !updates_needed
-
-let () = main_program approx ()
diff --git a/debian/changelog b/debian/changelog
index 7578806..d3b9fce 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+approx (5.0-1~bpo50+1) lenny-backports-sloppy; urgency=low
+
+  * Backport to lenny
+
+ -- Eric Cooper <ecc at cmu.edu>  Thu, 05 May 2011 23:04:25 -0400
+
 approx (5.0-1) unstable; urgency=low
 
   * New upstream version
diff --git a/debian/compat b/debian/compat
index 45a4fb7..7f8f011 100644
--- a/debian/compat
+++ b/debian/compat
@@ -1 +1 @@
-8
+7
diff --git a/debian/control b/debian/control
index 07d6120..a960f54 100644
--- a/debian/control
+++ b/debian/control
@@ -5,8 +5,7 @@ Maintainer: Eric Cooper <ecc at cmu.edu>
 Uploaders: Sylvain Le Gall <gildor at debian.org>, Ralf Treinen <treinen at debian.org>
 DM-Upload-Allowed: yes
 Build-Depends:
- debhelper (>= 8.0),
- dh-ocaml,
+ debhelper (>= 7.0),
  libnethttpd-ocaml-dev,
  libpcre-ocaml-dev,
  libsha-ocaml-dev,
diff --git a/debian/rules b/debian/rules
index 5d708b5..148e867 100755
--- a/debian/rules
+++ b/debian/rules
@@ -1,7 +1,7 @@
 #!/usr/bin/make -f
 
 %:
-	dh $@ --with ocaml
+	dh $@
 
 ifeq ($(wildcard /usr/bin/ocamlopt),)
 override_dh_auto_build:
diff --git a/program.ml b/program.ml
index cf82745..d17daba 100644
--- a/program.ml
+++ b/program.ml
@@ -28,11 +28,7 @@ let perform f x =
   with e -> error_message "%s" (string_of_exception e)
 
 let backtrace () =
-  let bt = Printexc.get_backtrace () in
-  if bt <> "" then
-    let lines = split_lines bt in
-    error_message "%s" "Uncaught exception";
-    List.iter (fun s ->  if s <> "" then error_message "  %s" s) lines
+  ()
 
 let main_program f x =
   try f x

-- 
approx upstream and debian packaging



More information about the Pkg-ocaml-maint-commits mailing list