The following commit has been merged in the lenny-backport branch: commit d7dc25f8b52c80e2b45336087bb83a0c3f8ccde7 Author: Eric Cooper <e...@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 <e...@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 <e...@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 <e...@cmu.edu> Uploaders: Sylvain Le Gall <gil...@debian.org>, Ralf Treinen <trei...@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 _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits