[Pkg-ocaml-maint-commits] r5322 - in /trunk/projects/approx/trunk: ./ debian/ doc/
ecc-guest at users.alioth.debian.org
ecc-guest at users.alioth.debian.org
Thu Mar 13 19:51:48 UTC 2008
Author: ecc-guest
Date: Thu Mar 13 19:51:48 2008
New Revision: 5322
URL: http://svn.debian.org/wsvn/?sc=1&rev=5322
Log:
added transparent proxying for requests that should be passed through
without caching, so approx can be used with mirroring scripts that use wget -r
Added:
trunk/projects/approx/trunk/config.ml
- copied, changed from r5317, trunk/projects/approx/trunk/default_config.ml
trunk/projects/approx/trunk/config.mli
- copied, changed from r5317, trunk/projects/approx/trunk/default_config.mli
trunk/projects/approx/trunk/config_file.ml
- copied unchanged from r5317, trunk/projects/approx/trunk/config.ml
trunk/projects/approx/trunk/config_file.mli
- copied unchanged from r5171, trunk/projects/approx/trunk/config.mli
Removed:
trunk/projects/approx/trunk/default_config.ml
trunk/projects/approx/trunk/default_config.mli
Modified:
trunk/projects/approx/trunk/Makefile
trunk/projects/approx/trunk/_tags
trunk/projects/approx/trunk/approx.ml
trunk/projects/approx/trunk/control_file.ml
trunk/projects/approx/trunk/debian/NEWS
trunk/projects/approx/trunk/debian/changelog
trunk/projects/approx/trunk/doc/approx.conf.5
trunk/projects/approx/trunk/gc.ml
trunk/projects/approx/trunk/log.ml
trunk/projects/approx/trunk/log.mli
trunk/projects/approx/trunk/pdiff.ml
trunk/projects/approx/trunk/release.ml
trunk/projects/approx/trunk/update.ml
trunk/projects/approx/trunk/url.ml
trunk/projects/approx/trunk/url.mli
trunk/projects/approx/trunk/util.ml
trunk/projects/approx/trunk/util.mli
Modified: trunk/projects/approx/trunk/Makefile
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/Makefile?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/Makefile (original)
+++ trunk/projects/approx/trunk/Makefile Thu Mar 13 19:51:48 2008
@@ -17,6 +17,9 @@
@mv -v gc gc_approx
@mv -v update update_approx
+fast:
+ @$(MAKE) all OCAMLBUILD_OPTS=
+
clean:
$(OCAMLBUILD) $(OCAMLBUILD_OPTS) -clean
rm -f approx gc_approx update_approx
Modified: trunk/projects/approx/trunk/_tags
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/_tags?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/_tags (original)
+++ trunk/projects/approx/trunk/_tags Thu Mar 13 19:51:48 2008
@@ -5,7 +5,7 @@
<**/*.{mli,ml}>: warn_error_A
<approx.ml>: use_pcre, use_netstring, use_netcgi, use_nethttpd-for-netcgi2
-<config.ml>: use_pcre
+<config_file.ml>: use_pcre
<log.ml>: use_syslog
<server.mli>: use_nethttpd-for-netcgi2
<server.ml>: use_netstring, use_netcgi, use_nethttpd-for-netcgi2
Modified: trunk/projects/approx/trunk/approx.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/approx.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/approx.ml (original)
+++ trunk/projects/approx/trunk/approx.ml Thu Mar 13 19:51:48 2008
@@ -8,7 +8,7 @@
open Unix
open Unix.LargeFile
open Util
-open Default_config
+open Config
open Log
let usage () =
@@ -36,8 +36,7 @@
| _ -> usage ()
done
-let stat_file name =
- try Some (stat name) with Unix_error (ENOENT, "stat", _) -> None
+let stat_file name = try Some (stat name) with Unix_error _ -> None
(* Temporary name in case the download is interrupted *)
@@ -54,7 +53,7 @@
so we can create our own *)
rm name'
end else begin
- if prev = 0L && debug then
+ if prev = 0L then
debug_message "Waiting for concurrent download of %s" name;
sleep 1;
wait (if cur = prev then n + 1 else 0) cur
@@ -63,7 +62,7 @@
in
wait 0 0L
-let print_headers msg headers =
+let debug_headers msg headers =
debug_message "%s" msg;
List.iter (fun (x, y) -> debug_message " %s: %s" x y) headers
@@ -81,7 +80,7 @@
let deliver_local name env =
let size = file_size name in
env#set_output_header_fields (proxy_headers size (file_modtime name));
- if debug then print_headers "Local response" env#output_header_fields;
+ debug_headers "Local response" env#output_header_fields;
Done (`File (`Ok, None, cache_dir ^/ name, 0L, size))
let not_found = Done (`Std_response (`Not_found, None, None))
@@ -89,16 +88,17 @@
let cache_hit name ims mod_time env =
if Release.immutable name || Release.valid_file name then
- if mod_time <= ims then
- (if debug then debug_message " => not modified";
- not_modified)
- else
- (if debug then debug_message " => delivering from cache";
- deliver_local name env)
+ if mod_time <= ims then begin
+ debug_message " => not modified";
+ not_modified
+ end else begin
+ debug_message " => delivering from cache";
+ deliver_local name env
+ end
else Missing
let deny name =
- if debug then debug_message "Denying %s" name;
+ debug_message "Denying %s" name;
not_found
(* See if the given file should be denied (reported to the client as
@@ -149,61 +149,68 @@
(* open file exclusively so we don't conflict with a concurrent download *)
open_out_excl path
-let cache_chan = ref None
-let cache_file = ref ""
-let tmp_cache_file = ref ""
-
-let open_cache name =
- assert (!cache_chan = None);
- try
- if debug then debug_message " open cache %s" name;
- cache_file := name;
- tmp_cache_file := in_progress name;
- cache_chan := Some (create_file !tmp_cache_file)
- with e ->
- error_message "Cannot cache %s" name;
- raise e
-
-let write_cache str pos len =
- match !cache_chan with
- | None -> assert false
- | Some chan -> output chan str pos len
+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] = '/'
+
+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;
+ let tmp_file = in_progress file in
+ let chan = create_file 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 size mod_time =
- match !cache_chan with
- | None -> assert false
- | Some chan ->
- let real_name = !cache_file in
- let tmp_name = !tmp_cache_file in
- if debug then debug_message " close cache %s" real_name;
+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;
- cache_chan := None;
- if size = file_size tmp_name then begin
- Sys.rename tmp_name real_name;
+ if size = file_size tmp_file then begin
+ Sys.rename tmp_file file;
if mod_time <> 0. then begin
- if debug then
- debug_message " setting mtime to %s"
- (Url.string_of_time mod_time);
- utimes real_name mod_time mod_time
- end;
+ debug_message " setting mtime to %s" (Url.string_of_time mod_time);
+ utimes file mod_time mod_time
+ end
end else begin
error_message "Size of %s should be %Ld, not %Ld"
- real_name size (file_size tmp_name);
- Sys.remove tmp_name;
+ file size (file_size tmp_file);
+ Sys.remove tmp_file;
raise Wrong_size
end
-
-let remove_cache () =
- match !cache_chan with
- | None -> ()
- | Some chan ->
- let tmp_name = !tmp_cache_file in
+ | Pass_through -> ()
+ | Undefined -> assert false
+
+let remove_cache cache =
+ match cache with
+ | Cache { tmp_file = tmp_file; chan = chan } ->
close_out chan;
- cache_chan := None;
- error_message "Removing %s (size: %Ld)" tmp_name (file_size tmp_name);
- Sys.remove tmp_name
+ error_message "Removing %s (size: %Ld)" tmp_file (file_size tmp_file);
+ Sys.remove tmp_file
+ | Pass_through | Undefined -> ()
type download_status =
| Delivered
@@ -216,14 +223,6 @@
| Cached -> "cached"
| Not_modified -> "not modified"
| File_not_found -> "not found"
-
-let send_header size modtime cgi =
- let cgi : Netcgi1_compat.Netcgi_types.cgi_activation = cgi in
- let headers = proxy_headers size modtime in
- let fields = List.map (fun (name, value) -> (name, [value])) headers in
- cgi#set_header ~status: `Ok ~fields ();
- if debug then
- print_headers "Proxy response" cgi#environment#output_header_fields
type response_state =
{ name : string;
@@ -231,22 +230,49 @@
mutable length : int64;
mutable last_modified : float;
mutable location : string;
- mutable body_seen : bool }
+ mutable content_type : string;
+ mutable body_seen : bool;
+ mutable cache : cache_state }
let new_response =
let initial_state =
- { name = "?";
+ { name = "";
status = 0;
length = -1L;
last_modified = 0.;
location = "";
- body_seen = false }
- in
- fun name -> { initial_state with name = name }
+ content_type = "text/plain";
+ body_seen = false;
+ cache = Undefined }
+ in
+ fun url name -> { initial_state with name = name; location = url }
+
+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]] @
+ (if resp.length >= 0L then
+ ["Content-Length", [Int64.to_string resp.length]]
+ else [])
+ in
+ cgi#set_header ~status: `Ok ~fields ();
+ debug_headers "Pass-through response" cgi#environment#output_header_fields
let finish_delivery resp =
- close_cache resp.length resp.last_modified;
- if resp.length >= 0L then Delivered else Cached
+ if should_pass_through (relative_url resp.location) then
+ (* the request was redirected to content that should not be cached,
+ like a directory listing *)
+ remove_cache resp.cache
+ else
+ close_cache resp.cache resp.length resp.last_modified;
+ if resp.length >= 0L or resp.cache = Pass_through then Delivered else Cached
let with_pair rex str proc =
match Pcre.extract ~rex ~full_match: false str with
@@ -274,45 +300,54 @@
(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
- if debug then debug_message " %s" str;
+ 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
- let size = resp.length in
+ if resp.status = 200 then begin
if not resp.body_seen then begin
resp.body_seen <- true;
- open_cache resp.name;
- if size >= 0L then
- (* we can start our response now *)
- send_header size resp.last_modified cgi
+ 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 str pos len;
- if size >= 0L then
+ 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 repository *)
-let download_http url name ims cgi =
+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 rec loop u redirects =
- let resp = new_response name in
- let header_callback = process_header resp in
- let body_callback = process_body resp cgi in
- Url.download u ~headers ~header_callback body_callback;
+ let header_callback = process_header resp in
+ let body_callback = process_body resp cgi in
+ let rec loop redirects =
+ resp.status <- 0;
+ Url.download resp.location ~headers ~header_callback body_callback;
match resp.status with
| 200 -> finish_delivery resp
| 304 -> Not_modified
| 301 | 302 | 303 | 307 ->
- if redirects < max_redirects then loop resp.location (redirects + 1)
+ if redirects < max_redirects then loop (redirects + 1)
else begin
error_message "Too many redirections for %s" url;
File_not_found
@@ -320,25 +355,21 @@
| 404 -> File_not_found
| n -> error_message "Unexpected status code: %d" n; File_not_found
in
- loop url 0
+ loop 0
(* Download a file from an FTP repository *)
-let download_ftp url name ims cgi =
- let resp = new_response name in
- let header_callback = process_header resp in
- Url.head url header_callback;
+let download_ftp resp url name ims cgi =
+ Url.head url (process_header resp);
let mod_time = resp.last_modified in
- if debug then
- 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
- let body_callback = process_body resp cgi 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 begin
resp.status <- 200; (* for process_body *)
- Url.download url body_callback;
+ Url.download url (process_body resp cgi);
finish_delivery resp
+ end
let download_url url name ims cgi =
let dl =
@@ -346,10 +377,11 @@
| Url.HTTP -> download_http
| Url.FTP | Url.FILE -> download_ftp
in
- try dl url name ims cgi
+ let resp = new_response url name in
+ try dl resp url name ims cgi
with e ->
- remove_cache ();
- if verbose && e <> Failure url then exception_message e;
+ remove_cache resp.cache;
+ if e <> Failure url then info_message "%s" (string_of_exception e);
File_not_found
(* Perform any pdiff processing triggered by downloading a given file *)
@@ -357,7 +389,7 @@
let cleanup_after url file =
if pdiffs && Release.is_pdiff file then
try Pdiff.apply file
- with e -> if verbose then exception_message e
+ with e -> info_message "%s" (string_of_exception e)
let copy_to dst src =
let len = 4096 in
@@ -388,7 +420,7 @@
else respond `Not_modified
in
let status = download_url url name (max ims mod_time) cgi in
- if verbose then info_message "%s: %s" url (string_of_download_status status);
+ info_message "%s: %s" url (string_of_download_status status);
match status with
| Delivered ->
cgi#output#commit_work ();
@@ -419,7 +451,7 @@
or it hasn't been verified recently enough *)
let cache_miss url name ims mod_time =
- if debug then debug_message " => cache miss";
+ debug_message " => cache miss";
`Accept_body (remote_service url name ims mod_time)
let ims_time env =
@@ -431,16 +463,17 @@
let serve_file env =
(* handle URL-encoded '+', '~', etc. *)
let path = Netencoding.Url.decode ~plus: false env#cgi_request_uri in
- let headers = env#input_header_fields in
- if debug then print_headers (sprintf "Request %s" path) headers;
+ debug_headers (sprintf "Request %s" path) env#input_header_fields;
try
let url, name = Url.translate_request path in
- let ims = ims_time env in
- match serve_local name ims env with
- | Done reaction -> reaction
- | Stale mod_time -> cache_miss url name ims mod_time
- | Missing -> cache_miss url name ims 0.
- with Invalid_argument msg | Failure msg -> forbidden msg
+ 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
+ | Stale mod_time -> cache_miss url name ims mod_time
+ | Missing -> cache_miss url name ims 0.
+ with Failure msg | Invalid_argument msg-> forbidden msg
let proxy_service =
object
@@ -448,19 +481,21 @@
method def_term = `Proxy_service
method print fmt = Format.fprintf fmt "%s" "proxy_service"
method process_header env =
- let remote =
- Server.remote_address env#remote_socket_addr ~with_port: true
- in
- if debug then debug_message "Connection from %s" remote;
+ debug_message "Connection from %s"
+ (Server.remote_address env#remote_socket_addr ~with_port: true);
if env#cgi_request_method = "GET" && env#cgi_query_string = "" then
serve_file env
- else forbidden "invalid HTTP request"
+ else begin
+ debug_headers (sprintf "Request %s" env#cgi_request_uri)
+ env#input_header_fields;
+ forbidden "invalid HTTP request"
+ end
end
let server s =
Sys.chdir cache_dir;
info_message "Version: %s" Version.number;
- if verbose then print_config (info_message "%s");
+ print_config (info_message "%s");
Server.loop s proxy_service
let daemonize proc x =
@@ -477,5 +512,5 @@
if !foreground then server s
else daemonize server s
with e ->
- exception_message e;
+ error_message "%s" (string_of_exception e);
exit 1
Copied: trunk/projects/approx/trunk/config.ml (from r5317, trunk/projects/approx/trunk/default_config.ml)
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/config.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/default_config.ml (original)
+++ trunk/projects/approx/trunk/config.ml Thu Mar 13 19:51:48 2008
@@ -1,8 +1,8 @@
(* approx: proxy server for Debian archive files
- Copyright (C) 2007 Eric C. Cooper <ecc at cmu.edu>
+ Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
Released under the GNU General Public License *)
-open Config
+open Config_file
let config_file = "/etc/approx/approx.conf"
let cache_dir = "/var/cache/approx"
@@ -30,6 +30,7 @@
pf "Interface: %s" interface;
pf "Port: %d" port;
pf "Max rate: %s" max_rate;
+ pf "Max redirects: %d" max_redirects;
pf "User: %s" user;
pf "Group: %s" group;
pf "Syslog: %s" syslog;
Copied: trunk/projects/approx/trunk/config.mli (from r5317, trunk/projects/approx/trunk/default_config.mli)
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/config.mli?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/default_config.mli (original)
+++ trunk/projects/approx/trunk/config.mli Thu Mar 13 19:51:48 2008
@@ -1,5 +1,5 @@
(* approx: proxy server for Debian archive files
- Copyright (C) 2007 Eric C. Cooper <ecc at cmu.edu>
+ Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
Released under the GNU General Public License *)
val config_file : string
Modified: trunk/projects/approx/trunk/control_file.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/control_file.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/control_file.ml (original)
+++ trunk/projects/approx/trunk/control_file.ml Thu Mar 13 19:51:48 2008
@@ -5,7 +5,7 @@
open Printf
open Util
open Log
-open Default_config
+open Config
type paragraph = (string * string) list
@@ -146,8 +146,8 @@
match validate ~checksum info file with
| Valid -> true
| Wrong_size n' ->
- if debug then debug_message "%s: size %Ld should be %Ld" file n' n;
+ debug_message "%s: size %Ld should be %Ld" file n' n;
false
| Wrong_checksum s' ->
- if debug then debug_message "%s: checksum %s should be %s" file s' s;
+ debug_message "%s: checksum %s should be %s" file s' s;
false
Modified: trunk/projects/approx/trunk/debian/NEWS
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/debian/NEWS?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/debian/NEWS (original)
+++ trunk/projects/approx/trunk/debian/NEWS Thu Mar 13 19:51:48 2008
@@ -1,4 +1,4 @@
-approx (3.1.0) unstable; urgency=low
+approx (3.1.0~rc1) experimental; urgency=low
TCP wrappers support has been added. Access control rules can be specified
for the approx daemon in /etc/hosts.allow and /etc/hosts.deny.
@@ -10,7 +10,12 @@
A new configuration parameter, $max_redirects, specifies the maximum number
of HTTP redirections that will be followed when downloading a remote file.
- -- Eric Cooper <ecc at cmu.edu> Sun, 09 Mar 2008 17:11:57 -0400
+ Requests for directories are now passed through without caching, so that
+ tools like "wget -r" can be used to mirror a repository known to approx.
+ Directory requests are detected by a path with a trailing / (or an HTTP
+ redirection to one).
+
+ -- Eric Cooper <ecc at cmu.edu> Thu, 13 Mar 2008 10:05:56 -0400
approx (3.0.0) unstable; urgency=low
Modified: trunk/projects/approx/trunk/debian/changelog
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/debian/changelog?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/debian/changelog (original)
+++ trunk/projects/approx/trunk/debian/changelog Thu Mar 13 19:51:48 2008
@@ -1,13 +1,15 @@
-approx (3.1.0) unstable; urgency=low
+approx (3.1.0~rc1) experimental; urgency=low
* Added support for IPv6 and TCP wrappers
- added build-dependency on libwrap0-dev
- closes: #468058
* Fixed mishandling of HTTP redirections
- - handle redirection status codes and location headers in approx.ml
- - remove --location option from Url.download (but not Url.download_file)
- - patch supplied by HÃ¥kon Stordahl <haastord at online.no>
+ - handle redirection status codes and location headers in approx.ml,
+ following patch supplied by HÃ¥kon Stordahl <haastord at online.no>
+ - remove curl --location option from Url.download but not Url.download_file
- closes: #469580
+ * Added transparent proxying for requests that should be passed through
+ without caching (closes: #469616)
* Perform server initializations like binding to port and dropping privileges
before daemonizing, so that any failures will be noticed by the init script
(closes: #465450)
@@ -20,12 +22,15 @@
- new, simpler Makefile
- updated debian/rules to deal with .native and .byte targets
* Improved documentation of the garbage collection algorithm in gc.ml
- * Stylistic changes (mostly whitespace-only)
+ * Changed debug_message and info_message to check corresponding
+ config parameters ($debug, $verbose) so callers don't have to
+ * Renamed config -> config_file and default_config -> config
+ * Style changes (mostly whitespace-only)
- use only spaces in indentation, no tabs
- write lists like this: [1; 2; 3]
- avoid single begin/end lines
- -- Eric Cooper <ecc at cmu.edu> Sun, 09 Mar 2008 17:11:57 -0400
+ -- Eric Cooper <ecc at cmu.edu> Thu, 13 Mar 2008 10:05:56 -0400
approx (3.0.0) unstable; urgency=low
Modified: trunk/projects/approx/trunk/doc/approx.conf.5
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/doc/approx.conf.5?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/doc/approx.conf.5 (original)
+++ trunk/projects/approx/trunk/doc/approx.conf.5 Thu Mar 13 19:51:48 2008
@@ -2,7 +2,7 @@
.\" Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
.\" Released under the GNU General Public License
.\" -*- nroff -*-
-.TH APPROX.CONF 5 "February 2008"
+.TH APPROX.CONF 5 "March 2008"
.\" Please adjust this date when revising the manpage.
.SH NAME
Modified: trunk/projects/approx/trunk/gc.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/gc.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/gc.ml (original)
+++ trunk/projects/approx/trunk/gc.ml Thu Mar 13 19:51:48 2008
@@ -9,7 +9,7 @@
distribution, is assumed to be invalid, and removed. *)
open Util
-open Default_config
+open Config
open Control_file
let usage () =
@@ -42,9 +42,6 @@
let simulate = !simulate
let quiet = !quiet
let verbose = !verbose
-
-let print_if yes fmt =
- Printf.ksprintf (fun str -> if yes then prerr_endline str) fmt
(* The cache is probably only a small subset of all the files in the
Debian archive, so we start with a table of filenames actually
@@ -169,6 +166,8 @@
| list -> List.iter remove_dir list; if not simulate then prune ()
let garbage_collect () =
+ (* gc must run as the approx user even in simulate mode,
+ because index files are decompressed in the cache *)
drop_privileges ~user ~group;
mark ();
sweep ();
Modified: trunk/projects/approx/trunk/log.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/log.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/log.ml (original)
+++ trunk/projects/approx/trunk/log.ml Thu Mar 13 19:51:48 2008
@@ -1,5 +1,5 @@
(* approx: proxy server for Debian archive files
- Copyright (C) 2007 Eric C. Cooper <ecc at cmu.edu>
+ Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
Released under the GNU General Public License *)
open Printf
@@ -8,7 +8,7 @@
let printer = ref (fun _ msg -> prerr_string msg; flush stderr)
-let message level =
+let message enabled level =
(* ensure message is newline-terminated,
otherwise syslog-ng behaves differently than syslog *)
let terminate str =
@@ -17,15 +17,15 @@
else if str.[n - 1] = '\n' then str
else str ^ "\n"
in
- ksprintf (fun str -> !printer level (terminate str))
+ ksprintf (fun str -> if enabled then !printer level (terminate str))
-let error_message fmt = message `LOG_ERR fmt
-let info_message fmt = message `LOG_INFO fmt
-let debug_message fmt = message `LOG_DEBUG fmt
+let error_message fmt = message true `LOG_ERR fmt
+let info_message fmt = message Config.verbose `LOG_INFO fmt
+let debug_message fmt = message Config.debug `LOG_DEBUG fmt
let exception_message exc = error_message "%s" (string_of_exception exc)
-let facility = facility_of_string Default_config.syslog
+let facility = facility_of_string Config.syslog
let use_syslog () =
try
Modified: trunk/projects/approx/trunk/log.mli
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/log.mli?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/log.mli (original)
+++ trunk/projects/approx/trunk/log.mli Thu Mar 13 19:51:48 2008
@@ -1,5 +1,5 @@
(* approx: proxy server for Debian archive files
- Copyright (C) 2007 Eric C. Cooper <ecc at cmu.edu>
+ Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
Released under the GNU General Public License *)
val use_syslog : unit -> unit
@@ -7,5 +7,3 @@
val error_message : ('a, unit, string, unit) format4 -> 'a
val info_message : ('a, unit, string, unit) format4 -> 'a
val debug_message : ('a, unit, string, unit) format4 -> 'a
-
-val exception_message : exn -> unit
Modified: trunk/projects/approx/trunk/pdiff.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/pdiff.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/pdiff.ml (original)
+++ trunk/projects/approx/trunk/pdiff.ml Thu Mar 13 19:51:48 2008
@@ -3,7 +3,7 @@
Released under the GNU General Public License *)
open Util
-open Default_config
+open Config
open Log
open Control_file
@@ -39,11 +39,11 @@
let check_pdiff (index_info, _, pdiff_info) next =
let check pdiff' =
if is_valid file_sha1sum pdiff_info pdiff' then begin
- if debug then debug_message "Parsing %s" pdiff;
+ debug_message "Parsing %s" pdiff;
let cmds = with_in_channel open_in pdiff' Patch.parse in
Some (index_info, cmds, next)
end else begin
- if debug then debug_message "Removing invalid %s" pdiff;
+ debug_message "Removing invalid %s" pdiff;
Sys.remove pdiff;
None
end
@@ -58,7 +58,7 @@
let compress ~src ~dst =
let cmd = Printf.sprintf "/bin/gzip -9 --no-name --stdout %s > %s" src dst in
- if debug then debug_message "Compressing: %s" cmd;
+ debug_message "Compressing: %s" cmd;
if Sys.command cmd <> 0 then failwith "compress"
(* Apply a pdiff to the given file *)
@@ -73,21 +73,21 @@
let apply pdiff =
let dir = Filename.dirname pdiff in
match find_pdiff pdiff (read_diff_index dir) with
- | None -> if debug then debug_message "%s not found in DiffIndex" pdiff
+ | None -> debug_message "%s not found in DiffIndex" pdiff
| Some (info, cmds, info') ->
let index = Filename.chop_suffix dir ".diff" ^ ".gz" in
let patch file =
if is_valid file_sha1sum info file then begin
apply_pdiff cmds file;
if is_valid file_sha1sum info' file then begin
- if debug then debug_message "Applied %s" pdiff;
+ debug_message "Applied %s" pdiff;
compress ~src: file ~dst: index;
Sys.remove pdiff
- end else (if debug then debug_message "Invalid result from %s" pdiff)
- end else (if debug then debug_message "Cannot apply %s" pdiff)
+ end else debug_message "Invalid result from %s" pdiff
+ end else debug_message "Cannot apply %s" pdiff
in
if Sys.file_exists index then decompress_and_apply patch index
- else (if debug then debug_message "Index %s not found" index)
+ else debug_message "Index %s not found" index
let remove_pdiffs pdiffs =
List.iter (fun (_, file, _) -> rm (file ^ ".gz")) pdiffs
@@ -96,12 +96,12 @@
let patch (index_info, name, pdiff_info) =
let pdiff = name ^ ".gz" in
let check_and_apply pdiff' =
- if is_valid file_sha1sum pdiff_info pdiff' then
- (if debug then debug_message "Parsing %s" pdiff;
- let cmds = with_in_channel open_in pdiff' Patch.parse in
- if is_valid file_sha1sum index_info file then apply_pdiff cmds file
- else (if debug then debug_message "Invalid index %s" file; raise Exit))
- else (if debug then debug_message "Invalid pdiff %s" pdiff; raise Exit)
+ if is_valid file_sha1sum pdiff_info pdiff' then begin
+ debug_message "Parsing %s" pdiff;
+ let cmds = with_in_channel open_in pdiff' Patch.parse in
+ if is_valid file_sha1sum index_info file then apply_pdiff cmds file
+ else (debug_message "Invalid index %s" file; raise Exit)
+ end else (debug_message "Invalid pdiff %s" pdiff; raise Exit)
in
if not (Sys.file_exists pdiff) then Url.download_file pdiff;
with_decompressed pdiff check_and_apply
@@ -109,10 +109,10 @@
try
List.iter patch pdiffs;
if is_valid file_sha1sum final file then begin
- if debug then debug_message "Updated %s" index;
+ debug_message "Updated %s" index;
compress ~src: file ~dst: index;
remove_pdiffs pdiffs
- end else (if debug then debug_message "Invalid update of %s" index)
+ end else debug_message "Invalid update of %s" index
with Exit -> ()
let update index =
@@ -120,12 +120,10 @@
let diffs, final = read_diff_index (directory index) in
let update_index file =
let info = (file_sha1sum file, file_size file) in
- if info = final then (if debug then debug_message "%s is current" index)
+ if info = final then debug_message "%s is current" index
else
match find_tail (fun (i, _, _) -> i = info) diffs with
- | [] ->
- if debug then debug_message "%s not found in DiffIndex" index;
- raise Not_found
+ | [] -> debug_message "%s not found in DiffIndex" index; raise Not_found
| list -> apply_pdiffs file list final index
in
decompress_and_apply update_index index
Modified: trunk/projects/approx/trunk/release.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/release.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/release.ml (original)
+++ trunk/projects/approx/trunk/release.ml Thu Mar 13 19:51:48 2008
@@ -3,7 +3,7 @@
Released under the GNU General Public License *)
open Util
-open Default_config
+open Config
open Log
type t = string * ((Control_file.info * string) list * (string -> string))
@@ -33,7 +33,7 @@
let info = fst (List.find (fun (_, name) -> name = rfile) info_list) in
Control_file.is_valid checksum info file
with Not_found ->
- if debug && Filename.dirname file <> rdir then
+ if Filename.dirname file <> rdir then
debug_message "%s: not found in %s/Release" file rdir;
false
Modified: trunk/projects/approx/trunk/update.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/update.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/update.ml (original)
+++ trunk/projects/approx/trunk/update.ml Thu Mar 13 19:51:48 2008
@@ -5,7 +5,7 @@
(* Update the Packages and Sources files in the approx cache *)
open Util
-open Default_config
+open Config
open Log
let usage () =
@@ -13,8 +13,9 @@
Update the approx cache
Options:
-k|--keep|-s|--simulate
- do not modify any files
- -q|--quiet do not print information about updates and removals";
+ do not modify or download any files
+ -q|--quiet do not print information about updates and removals
+ -v|--verbose print the status of each Packages or Sources file";
exit 1
let simulate = ref false
@@ -38,22 +39,7 @@
let verbose = !verbose
let files = List.rev !files
-let print_if yes = Printf.ksprintf (fun str -> if yes then prerr_endline str)
-
let print fmt = print_if true fmt
-
-let updates = Hashtbl.create 256
-
-let mark_updated file = Hashtbl.replace updates file ()
-
-let updated file = try Hashtbl.find updates file; true with Not_found -> false
-
-let update file =
- if not (simulate || updated file) then begin
- print_if (not quiet) "Updating %s" file;
- Url.download_file file;
- mark_updated file
- end
let remove_pdiffs dir =
match Filename.basename dir with
Modified: trunk/projects/approx/trunk/url.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/url.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/url.ml (original)
+++ trunk/projects/approx/trunk/url.ml Thu Mar 13 19:51:48 2008
@@ -4,7 +4,7 @@
open Printf
open Util
-open Default_config
+open Config
open Log
let string_of_time t =
@@ -24,15 +24,13 @@
let path = relative_url url in
match explode_path path with
| dist :: rest ->
- (try implode_path (Config.get dist :: rest), path
+ (try implode_path (Config_file.get dist :: rest), path
with Not_found -> failwith ("no remote repository for " ^ dist))
| [] ->
invalid_arg "translate_request"
let translate_file file =
- let dist, path = split_cache_path file in
- try Config.get dist ^/ path
- with Not_found -> invalid_arg ("translate_file " ^ file)
+ let dist, path = split_cache_path file in Config_file.get dist ^/ path
type protocol = HTTP | FTP | FILE
@@ -78,7 +76,7 @@
let head url callback =
let cmd = head_command url in
- if debug then debug_message "Command: %s" cmd;
+ debug_message "Command: %s" cmd;
with_process cmd ~error: url (iter_headers callback)
let download_command headers header_callback =
@@ -104,7 +102,7 @@
let download url ?(headers=[]) ?header_callback callback =
let cmd = download_command headers header_callback url in
- if debug then debug_message "Command: %s" cmd;
+ debug_message "Command: %s" cmd;
with_process cmd ~error: url
(match header_callback with
| Some proc -> seq (iter_headers proc) (iter_body callback)
@@ -120,7 +118,7 @@
else [])
in
let cmd = curl_command options (translate_file file) in
- if debug then debug_message "Command: %s" cmd;
+ debug_message "Command: %s" cmd;
if Sys.command cmd = 0 then
(* file' may not exist if file was not modified *)
try Sys.rename file' file with _ -> ()
Modified: trunk/projects/approx/trunk/url.mli
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/url.mli?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/url.mli (original)
+++ trunk/projects/approx/trunk/url.mli Thu Mar 13 19:51:48 2008
@@ -1,5 +1,5 @@
(* approx: proxy server for Debian archive files
- Copyright (C) 2007 Eric C. Cooper <ecc at cmu.edu>
+ Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
Released under the GNU General Public License *)
(* Translate a request URL to the remote repository URL and
@@ -14,7 +14,8 @@
val split_cache_path : string -> string * string
-(* Find the remote URL corresponding to a given file in the cache *)
+(* Find the remote URL corresponding to a given file in the cache,
+ or raise Not_found if it does not correspond to a known mapping *)
val translate_file : string -> string
Modified: trunk/projects/approx/trunk/util.ml
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/util.ml?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/util.ml (original)
+++ trunk/projects/approx/trunk/util.ml Thu Mar 13 19:51:48 2008
@@ -79,6 +79,8 @@
let without_extension file = fst (split_extension file)
let extension file = snd (split_extension file)
+
+let the = function Some x -> x | None -> raise Not_found
(* private exception to wrap any exception raised during cleanup action *)
@@ -269,3 +271,5 @@
with e ->
prerr_endline (string_of_exception e);
exit 1
+
+let print_if cond = ksprintf (fun str -> if cond then prerr_endline str)
Modified: trunk/projects/approx/trunk/util.mli
URL: http://svn.debian.org/wsvn/trunk/projects/approx/trunk/util.mli?rev=5322&op=diff
==============================================================================
--- trunk/projects/approx/trunk/util.mli (original)
+++ trunk/projects/approx/trunk/util.mli Thu Mar 13 19:51:48 2008
@@ -1,5 +1,5 @@
(* approx: proxy server for Debian archive files
- Copyright (C) 2007 Eric C. Cooper <ecc at cmu.edu>
+ Copyright (C) 2008 Eric C. Cooper <ecc at cmu.edu>
Released under the GNU General Public License *)
(* Check if the first string is a prefix of the second *)
@@ -61,6 +61,10 @@
val extension : string -> string
+(* Return the underlying value of an option, otherwise raise Not_found *)
+
+val the : 'a option -> 'a
+
(* Call a function making sure that a cleanup procedure is called
before returning the result of the function or raising an exception *)
@@ -190,3 +194,7 @@
(* Run the main function of a program and print any uncaught exceptions *)
val main_program : ('a -> unit) -> 'a -> unit
+
+(* Conditionally print on stderr *)
+
+val print_if : bool -> ('a, unit, string, unit) format4 -> 'a
More information about the Pkg-ocaml-maint-commits
mailing list