[Pkg-ocaml-maint-commits] r1686 - in trunk/projects/approx: .
branches branches/nethttpd branches/nethttpd/debian
branches/nethttpd/doc
Eric Cooper
ecc-guest at costa.debian.org
Tue Aug 23 21:33:58 UTC 2005
Author: ecc-guest
Date: 2005-08-23 21:33:57 +0000 (Tue, 23 Aug 2005)
New Revision: 1686
Added:
trunk/projects/approx/branches/
trunk/projects/approx/branches/nethttpd/
trunk/projects/approx/branches/nethttpd/gen_version
trunk/projects/approx/branches/nethttpd/log.ml
trunk/projects/approx/branches/nethttpd/log.mli
trunk/projects/approx/branches/nethttpd/server.ml
trunk/projects/approx/branches/nethttpd/server.mli
trunk/projects/approx/branches/nethttpd/version.mli
Modified:
trunk/projects/approx/branches/nethttpd/Makefile
trunk/projects/approx/branches/nethttpd/approx.ml
trunk/projects/approx/branches/nethttpd/debian/changelog
trunk/projects/approx/branches/nethttpd/debian/control
trunk/projects/approx/branches/nethttpd/debian/copyright
trunk/projects/approx/branches/nethttpd/debian/rules
trunk/projects/approx/branches/nethttpd/doc/approx.8
trunk/projects/approx/branches/nethttpd/gc_approx.ml
trunk/projects/approx/branches/nethttpd/release.ml
trunk/projects/approx/branches/nethttpd/util.ml
trunk/projects/approx/branches/nethttpd/util.mli
Log:
created nethttpd branch:
approx server side uses nethttpd from ocamlnet instead of ocaml-http
Copied: trunk/projects/approx/branches/nethttpd (from rev 1685, trunk/projects/approx/trunk)
Modified: trunk/projects/approx/branches/nethttpd/Makefile
===================================================================
--- trunk/projects/approx/trunk/Makefile 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/Makefile 2005-08-23 21:33:57 UTC (rev 1686)
@@ -7,9 +7,9 @@
export OCAMLFLAGS = -w A
define PROJ_server
- SOURCES = util.ml config.ml default_config.ml url.ml control_file.ml release.ml approx.ml
- INCDIRS = +pcre +syslog +netstring +http +curl
- LIBS = unix pcre syslog netstring http curl
+ SOURCES = util.ml config.ml default_config.ml log.ml url.ml control_file.ml release.ml server.ml version.ml approx.ml
+ INCDIRS = +pcre +syslog +netstring +cgi +nethttpd +curl
+ LIBS = unix pcre syslog netstring cgi nethttpd curl
RESULT = approx
endef
export PROJ_server
Modified: trunk/projects/approx/branches/nethttpd/approx.ml
===================================================================
--- trunk/projects/approx/trunk/approx.ml 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/approx.ml 2005-08-23 21:33:57 UTC (rev 1686)
@@ -4,40 +4,40 @@
open Util
open Default_config
-open Http_daemon
open Printf
+open Nethttpd_types
open Unix
+open Log (* Log.error_message shadows Unix.error_message *)
let usage () =
- prerr_endline "Usage: approx [options]";
- prerr_endline "Proxy server for Debian archive files";
- prerr_endline "Options:";
- prerr_endline " -f|--foreground stay in foreground instead of detaching";
+ prerr_endline
+ "Usage: approx [options]
+Proxy server for Debian archive files
+
+Options:
+ -f|--foreground remain in foreground instead of detaching
+ -h|--help display this message and exit
+ -v|--version display version information and exit";
exit 1
+let version () =
+ eprintf "%s %s\n" Version.name Version.number;
+ prerr_endline
+ "Copyright (C) 2005 Eric C. Cooper <ecc at cmu.edu>
+Released under the GNU General Public License"
+
let foreground = ref false
let () =
for i = 1 to Array.length Sys.argv - 1 do
match Sys.argv.(i) with
| "-f" | "--foreground" -> foreground := true
+ | "-v" | "--version" -> version ()
| _ -> usage ()
done
-let print_message =
- if !foreground then
- fun _ -> prerr_endline
- else
- let prog = Filename.basename Sys.argv.(0) in
- let log = Syslog.openlog ~facility: `LOG_DAEMON prog in
- Syslog.syslog log
+let () = if not !foreground then use_syslog ()
-let message level fmt = kprintf (print_message level) fmt
-
-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 exception_message exc =
match exc with
| Sys_error str ->
@@ -48,12 +48,10 @@
error_message "Invalid argument: %s" str
| Curl.CurlException (_, _, str) ->
error_message "Curl exception: %s" str
+ | Unix_error (err, str, "") ->
+ error_message "%s: %s" str (Unix.error_message err)
| Unix_error (err, str, arg) ->
- if err = EADDRINUSE && str = "bind" then
- error_message "Port %d is already in use" port
- else
- error_message "%s: %s%s" str (Unix.error_message err)
- (if arg = "" then "" else sprintf " (%s)" arg)
+ error_message "%s: %s (%s)" str (Unix.error_message err) arg
| e ->
error_message "%s" (Printexc.to_string e)
@@ -76,51 +74,6 @@
let string_of_time = http_time
-(* Note that if we include a Content-Length field in our response,
- APT assumes that we will keep the connection alive.
- If we close it instead, APT prints error messages of the form
- Error reading from server - read (104 Connection reset by peer)
- or passes partial files to gzip for decompression, resulting in
- Sub-process gzip returned an error code (1) *)
-
-let has_header h =
- let h = String.lowercase h in
- let rec loop = function
- | (name, _) :: rest ->
- if String.lowercase name = h then true
- else loop rest
- | [] -> false
- in
- loop
-
-let response_headers ?(msg = "Local") code headers chan =
- send_basic_headers chan ~code: (`Code code);
- if debug then
- begin
- debug_message "%s response: %d" msg code;
- List.iter (fun (x, y) -> debug_message " %s: %s" x y) headers
- end;
- send_headers chan ~headers;
- if not (has_header "Connection" headers) then
- send_headers chan ~headers: [ "Connection", "keep-alive" ];
- if code = 200 && not (has_header "Content-Length" headers) then
- error_message "No HTTP Content-Length header";
- send_CRLF chan
-
-let content_type file_name = "Content-Type", "text/plain"
-let content_lastmod time = "Last-Modified", http_time time
-let content_length length = "Content-Length", string_of_int length
-
-let proxy_headers file_name stats =
- response_headers 200
- [ content_type file_name;
- content_lastmod stats.st_mtime;
- content_length stats.st_size ]
-
-let relay_headers = response_headers ~msg: "HTTP proxy"
-
-let respond_not_modified = response_headers 304 []
-
let in_progress name = name ^ ".tmp" (* temporary name in case the download
is interrupted *)
@@ -144,24 +97,21 @@
in
wait 0
-let copy ~src ~dst =
- let len = 4096 in
- let buf = String.create len in
- let rec loop () =
- match input src buf 0 len with
- | 0 -> ()
- | n -> output dst buf 0 n; loop ()
- in
- loop ()
+let print_headers msg headers =
+ debug_message "%s" msg;
+ List.iter (fun (x, y) -> debug_message " %s: %s" x y) headers
+let proxy_headers name env =
+ env#set_output_header_field "Content-Type" "text/plain";
+ env#set_output_header_field "Last-Modified" (http_time (file_modtime name));
+ if debug then print_headers "Local response" env#output_header_fields
+
(* Deliver a file from the local cache *)
-let deliver_local name ochan =
- wait_for_download_in_progress name;
+let deliver_local name env =
if not debug then info_message "%s" name;
- with_channel open_in name (fun ichan ->
- proxy_headers name (fstat (descr_of_in_channel ichan)) ochan;
- copy ~src: ichan ~dst: ochan)
+ proxy_headers name env;
+ `File (`Ok, None, cache_dir ^/ name, 0L, file_size name)
(* Return the age of a file in minutes, using the last status change
time (ctime) rather than the modification time (mtime).
@@ -192,23 +142,27 @@
(* Attempt to serve the requested file from the local cache *)
-exception Stale of float
+exception Cache_miss of float
-let serve_local name ims ochan =
+let not_found () = raise (Cache_miss 0.)
+
+let stale mod_time = raise (Cache_miss mod_time)
+
+let serve_local name ims env =
wait_for_download_in_progress name;
let stats =
try stat name
- with Unix_error (ENOENT, "stat", _) -> raise Not_found
+ with Unix_error (ENOENT, "stat", _) -> not_found ()
in
if debug then print_age name stats ims;
if stats.st_kind <> S_REG then
- raise Not_found
+ not_found ()
else if is_mutable name && (always_refresh name || too_old stats) then
- raise (Stale stats.st_mtime)
+ stale stats.st_mtime
else if stats.st_mtime > ims then
- deliver_local name ochan
+ deliver_local name env
else
- respond_not_modified ochan
+ `Std_response (`Not_modified, None, None)
let make_directory path =
let rec loop cwd = function
@@ -253,7 +207,7 @@
output_string chan str;
flush chan
-let close_cache ?(mod_time=0.) ?(size=(-1)) () =
+let close_cache ?(mod_time=0.) ?(size=(-1L)) () =
match !cache_chan with
| None -> assert false
| Some chan ->
@@ -261,7 +215,7 @@
close_out chan;
cache_chan := None;
try
- if size = -1 || size = file_size !tmp_cache_file then
+ if size = -1L || size = file_size !tmp_cache_file then
begin
Sys.rename !tmp_cache_file !cache_file;
if mod_time <> 0. then
@@ -274,7 +228,7 @@
end
else
begin
- error_message "Size of %s should be %d" !cache_file size;
+ error_message "Size of %s should be %Ld" !cache_file size;
Sys.remove !tmp_cache_file
end
with e ->
@@ -289,7 +243,7 @@
let name = !tmp_cache_file in
close_out chan;
cache_chan := None;
- error_message "Removing %s (size: %d)" name (file_size name);
+ error_message "Removing %s (size: %Ld)" name (file_size name);
Sys.remove name
type download_status =
@@ -339,9 +293,9 @@
(* Respond to a request for a file at an HTTP repository *)
-let serve_http url name ims chan =
+let serve_http url name ims env output =
let header_list = ref [] in
- let length = ref (-1) in
+ let length = ref (-1L) in
let last_modified = ref 0. in
let chunked = ref false in
let add_header (header, value as pair) =
@@ -350,7 +304,7 @@
header_list := pair :: !header_list
| "content-length" ->
header_list := pair :: !header_list;
- (try length := int_of_string value
+ (try length := Int64.of_string value
with Failure _ ->
error_message "Cannot parse Content-Length value %s" value)
| "last-modified" ->
@@ -380,10 +334,13 @@
in
let body_seen = ref false in
let start_transfer () =
- open_cache name;
if not !chunked then
(* start our response now *)
- relay_headers !status (List.rev !header_list) chan
+ begin
+ env#set_output_header_fields !header_list;
+ if debug then print_headers "Proxy response" env#output_header_fields
+ end;
+ open_cache name
in
let body_callback str =
if !status = 200 then
@@ -392,10 +349,7 @@
write_cache str;
if not !chunked then
(* stream the data back to the client as we receive it *)
- begin
- output_string chan str;
- flush chan
- end
+ output#output_string str
end
in
let headers =
@@ -416,7 +370,7 @@
(* Respond to a request for a file at an FTP repository *)
-let serve_ftp url name ims chan =
+let serve_ftp url name ims env output =
let mod_time = Url.mod_time url in
if debug then
debug_message " ims %s mtime %s"
@@ -456,40 +410,65 @@
if Sys.file_exists name then
List.iter remove (Release.files_invalidated_by name)
-let serve_remote url name ims ims' chan =
- try
- info_message "%s" url;
- let status = serve_url url name (max ims ims') chan in
- if debug then
- debug_message " status: %s" (string_of_download_status status);
- match status with
- | Delivered ->
- cleanup_after name
- | Cached ->
- deliver_local name chan;
- cleanup_after name
- | Not_modified ->
- update_ctime name;
- if ims < ims' then
- deliver_local name chan
- else
- respond_not_modified chan
- | File_not_found ->
- respond_not_found ~url: name chan
- with e ->
- remove_cache ();
- exception_message e;
- respond_not_found ~url: name chan
+let copy src dst =
+ let len = 4096 in
+ let buf = String.create len in
+ let rec loop () =
+ match input src buf 0 len with
+ | 0 -> dst#flush ()
+ | n -> dst#really_output buf 0 n; loop ()
+ in
+ loop ()
-let ims_time headers =
- (* the OCaml HTTP library converts header names to lowercase *)
- try Netdate.parse_epoch (List.assoc "if-modified-since" headers)
- with Not_found | Invalid_argument _ -> 0.
+(* Similar to deliver_local, but we have to copy it ourselves *)
-let print_request path headers =
- debug_message "Request %s" path;
- List.iter (fun (x, y) -> debug_message " %s: %s" x y) headers
+let copy_from_cache name env output =
+ wait_for_download_in_progress name;
+ env#set_output_header_field "Content-Length"
+ (Int64.to_string (file_size name));
+ proxy_headers name env;
+ with_channel open_in name (fun input -> copy input output)
+let serve_remote url name ims mod_time env output =
+ info_message "%s" url;
+ let status =
+ try serve_url url name (max ims mod_time) env output
+ with e ->
+ remove_cache ();
+ exception_message e;
+ raise (Standard_response (`Not_found, None, Some "Download failed"))
+ in
+ if debug then
+ debug_message " status: %s" (string_of_download_status status);
+ match status with
+ | Delivered ->
+ cleanup_after name
+ | Cached ->
+ copy_from_cache name env output;
+ cleanup_after name
+ | Not_modified ->
+ update_ctime name;
+ if mod_time > ims then
+ (* the cached copy is newer than what the client has *)
+ copy_from_cache name env output
+ else
+ raise (Standard_response (`Not_modified, None, None))
+ | File_not_found ->
+ raise (Standard_response (`Not_found, None, None))
+
+let remote_service url name ims mod_time =
+ object
+ method process_body env =
+ let cgi =
+ Nethttpd_services.std_activation `Std_activation_buffered env
+ in
+ object
+ method generate_response env =
+ serve_remote url name ims mod_time env cgi#output;
+ cgi#output#commit_work ()
+ end
+ end
+
let validate_path path =
let name = relative_path path in
match explode_path name with
@@ -500,37 +479,51 @@
| [] ->
invalid_arg "invalid path"
-let serve_file path headers chan =
- if debug then print_request path headers;
+let ims_time env =
+ try Netdate.parse_epoch (env#input_header#field "If-Modified-Since")
+ with Not_found | Invalid_argument _ -> 0.
+
+let serve_file env =
+ let path = env#cgi_request_uri in
+ let headers = env#input_header_fields in
+ if debug then print_headers (sprintf "Request %s" path) headers;
try
let name, url = validate_path path in
- let ims = ims_time headers in
- try
- serve_local name ims chan
- with
- | Stale mtime ->
- (* old version in the local cache *)
- serve_remote url name ims mtime chan
- | Not_found ->
- (* file not in local cache *)
- serve_remote url name ims ims chan
+ let ims = ims_time env in
+ try serve_local name ims env
+ with Cache_miss mod_time ->
+ (* The file is either not present (mod_time = 0)
+ or it hasn't been verified recently enough.
+ In either case, we must contact the remote repository. *)
+ `Accept_body (remote_service url name ims mod_time)
with Invalid_argument msg ->
- error_message "%s: %s" path msg;
- respond_forbidden ~url: path chan
+ `Std_response (`Forbidden, None, Some msg)
-let callback req chan =
- info_message "Connection from %s" req#clientAddr;
- match req#params with
- | [] -> serve_file req#path req#headers chan
- | _ -> respond_forbidden ~url: req#path chan
+let proxy_service =
+ let version = Version.name ^/ Version.number in
+ object (self)
+ method name = "proxy_service"
+ method def_term = `Proxy_service
+ method print fmt = Format.fprintf fmt "%s" "proxy_service"
+ method process_header env =
+ (match env#remote_socket_addr with
+ | ADDR_INET (host, port) ->
+ info_message "Connection from %s:%d" (string_of_inet_addr host) port
+ | ADDR_UNIX path ->
+ failwith ("connection from UNIX socket " ^ path));
+ env#set_output_header_field "Server" version;
+ if env#cgi_request_method = "GET" && env#cgi_query_string = "" then
+ serve_file env
+ else
+ `Std_response (`Forbidden, None, Some "Invalid request line")
+ end
+
let server () =
- let mode = `Fork in
- let root_dir = Some cache_dir in
- let timeout = None in
try
+ Sys.chdir cache_dir;
print_config ();
- main (daemon_spec ~callback ~mode ~port ~root_dir ~timeout ())
+ Server.main port proxy_service
with e ->
exception_message e;
exit 1
Modified: trunk/projects/approx/branches/nethttpd/debian/changelog
===================================================================
--- trunk/projects/approx/trunk/debian/changelog 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/debian/changelog 2005-08-23 21:33:57 UTC (rev 1686)
@@ -1,3 +1,10 @@
+approx (1.50) unstable; urgency=low
+
+ * Changed server to use nethttpd from the ocamlnet library
+ instead of ocaml-http
+
+ -- Eric Cooper <ecc at cmu.edu> Mon, 22 Aug 2005 16:53:22 -0400
+
approx (1.18) unstable; urgency=low
* Secure APT imposes additional consistency requirements on the cache:
Modified: trunk/projects/approx/branches/nethttpd/debian/control
===================================================================
--- trunk/projects/approx/trunk/debian/control 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/debian/control 2005-08-23 21:33:57 UTC (rev 1686)
@@ -3,7 +3,7 @@
Priority: optional
Maintainer: Eric Cooper <ecc at cmu.edu>
Uploaders: Sven Luther <luther at debian.org>, Stefano Zacchiroli <zack at debian.org>
-Build-Depends: debhelper (>= 4.0), ocaml-nox-3.08.3, ocaml-best-compilers, ocaml-tools, libcurl-ocaml-dev (>= 0.2.1), libhttp-ocaml-dev (>= 0.1.1), libocamlnet-ocaml-dev (>= 1.1), libpcre-ocaml-dev (>= 5.10.0), libsyslog-ocaml-dev (>= 1.0-3)
+Build-Depends: debhelper (>= 4.0), ocaml-nox-3.08.3, ocaml-best-compilers, ocaml-tools, libcurl-ocaml-dev (>= 0.2.0), libocamlnet-ocaml-dev (>= 1.1), libpcre-ocaml-dev, libsyslog-ocaml-dev (>= 1.2)
Standards-Version: 3.6.2
Package: approx
Modified: trunk/projects/approx/branches/nethttpd/debian/copyright
===================================================================
--- trunk/projects/approx/trunk/debian/copyright 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/debian/copyright 2005-08-23 21:33:57 UTC (rev 1686)
@@ -13,7 +13,7 @@
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
On Debian GNU/Linux systems, the complete text of the GNU General
Public License can be found in /usr/share/common-licenses/GPL.
Modified: trunk/projects/approx/branches/nethttpd/debian/rules
===================================================================
--- trunk/projects/approx/trunk/debian/rules 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/debian/rules 2005-08-23 21:33:57 UTC (rev 1686)
@@ -5,6 +5,7 @@
build: build-stamp
build-stamp:
dh_testdir
+ ./gen_version > version.ml
if [ -x /usr/bin/ocamlopt ]; then \
$(MAKE) native-code; \
else \
@@ -17,6 +18,7 @@
dh_testroot
rm -f build-stamp
-$(MAKE) clean
+ rm -f version.ml
dh_clean
install: build
Modified: trunk/projects/approx/branches/nethttpd/doc/approx.8
===================================================================
--- trunk/projects/approx/trunk/doc/approx.8 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/doc/approx.8 2005-08-23 21:33:57 UTC (rev 1686)
@@ -36,6 +36,11 @@
.BR \-f ", " \-\^\-foreground
Run in the foreground instead of detaching as a daemon,
and print messages to standard error instead of the system log.
+.TP
+.BR \-v ", " \-\^\-version
+Display
+.B approx
+version information and exit.
.SH EXAMPLES
By default,
@@ -91,19 +96,5 @@
.BR apt\-get (8),
.IR sources.list (5)
-.SH BUGS
-.PP
-When a client uses
-.BR apt\-get (8)
-to install a package that is not in the
-.B approx
-server's cache,
-the transfer will occasionally fail with an MD5 checksum error.
-In all of the cases the author has observed, the file has been cached
-correctly on the server,
-and re-running
-.BR apt\-get (8)
-solves the problem.
-
.SH AUTHOR
Eric Cooper <ecc at cmu.edu>
Modified: trunk/projects/approx/branches/nethttpd/gc_approx.ml
===================================================================
--- trunk/projects/approx/trunk/gc_approx.ml 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/gc_approx.ml 2005-08-23 21:33:57 UTC (rev 1686)
@@ -113,7 +113,7 @@
let mark_file prefix fields =
let file = canonical (List.assoc "filename" fields) in
- let size = int_of_string (List.assoc "size" fields) in
+ let size = Int64.of_string (List.assoc "size" fields) in
let md5sum = List.assoc "md5sum" fields in
let path = prefix ^/ file in
try
Added: trunk/projects/approx/branches/nethttpd/gen_version
===================================================================
--- trunk/projects/approx/trunk/gen_version 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/gen_version 2005-08-23 21:33:57 UTC (rev 1686)
@@ -0,0 +1,9 @@
+#!/usr/bin/perl -w
+use strict;
+
+open(CHANGELOG, "dpkg-parsechangelog |") or exit 1;
+while (<CHANGELOG>) {
+ /^Source:\s+(\S+)/ && print "let name = \"$1\"\n";
+ /^Version:\s+(\S+)/ && print "let number = \"$1\"\n";
+}
+close(CHANGELOG);
Property changes on: trunk/projects/approx/branches/nethttpd/gen_version
___________________________________________________________________
Name: svn:executable
+ *
Added: trunk/projects/approx/branches/nethttpd/log.ml
===================================================================
--- trunk/projects/approx/trunk/log.ml 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/log.ml 2005-08-23 21:33:57 UTC (rev 1686)
@@ -0,0 +1,14 @@
+open Printf
+
+let printer = ref (fun _ -> prerr_endline)
+
+let use_syslog () =
+ let prog = Filename.basename Sys.argv.(0) in
+ let log = Syslog.openlog ~facility: `LOG_DAEMON prog in
+ printer := Syslog.syslog log
+
+let message level fmt = kprintf (fun str -> !printer level str) fmt
+
+let error_message fmt = message `LOG_ERR fmt
+let info_message fmt = message `LOG_INFO fmt
+let debug_message fmt = message `LOG_DEBUG fmt
Added: trunk/projects/approx/branches/nethttpd/log.mli
===================================================================
--- trunk/projects/approx/trunk/log.mli 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/log.mli 2005-08-23 21:33:57 UTC (rev 1686)
@@ -0,0 +1,5 @@
+val use_syslog : unit -> unit
+
+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
Modified: trunk/projects/approx/branches/nethttpd/release.ml
===================================================================
--- trunk/projects/approx/trunk/release.ml 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/release.ml 2005-08-23 21:33:57 UTC (rev 1686)
@@ -13,7 +13,7 @@
let check_file md5sum size filename =
let file = path ^/ filename in
if Sys.file_exists file &&
- (file_size file <> int_of_string size || file_md5sum file <> md5sum)
+ (file_size file <> Int64.of_string size || file_md5sum file <> md5sum)
then
file :: invalid
else
Added: trunk/projects/approx/branches/nethttpd/server.ml
===================================================================
--- trunk/projects/approx/trunk/server.ml 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/server.ml 2005-08-23 21:33:57 UTC (rev 1686)
@@ -0,0 +1,38 @@
+open Printf
+open Unix
+open Nethttp
+open Nethttpd_reactor
+open Log (* Log.error_message shadows Unix.error_message *)
+
+let error_response code =
+ let msg =
+ try string_of_http_status (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
+ 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_timeout_next_request = 15.
+ method config_timeout = 300.
+ method config_cgi = Netcgi_env.default_config
+ method config_error_response n = error_response n
+ method config_log_error _ _ _ _ msg = error_message "%s" msg
+
+ method config_reactor_synch = `Write
+ end
+
+let main port service =
+ let session input output =
+ let fd = descr_of_in_channel input in
+ set_nonblock fd;
+ process_connection config fd service
+ in
+ establish_server session (ADDR_INET (inet_addr_any, port))
Added: trunk/projects/approx/branches/nethttpd/server.mli
===================================================================
--- trunk/projects/approx/trunk/server.mli 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/server.mli 2005-08-23 21:33:57 UTC (rev 1686)
@@ -0,0 +1 @@
+val main : int -> 'a Nethttpd_types.http_service -> unit
Modified: trunk/projects/approx/branches/nethttpd/util.ml
===================================================================
--- trunk/projects/approx/trunk/util.ml 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/util.ml 2005-08-23 21:33:57 UTC (rev 1686)
@@ -67,6 +67,6 @@
let file_modtime file = (stat file).st_mtime
-let file_size file = (stat file).st_size
+let file_size file = (LargeFile.stat file).LargeFile.st_size
let file_md5sum file = Digest.to_hex (Digest.file file)
Modified: trunk/projects/approx/branches/nethttpd/util.mli
===================================================================
--- trunk/projects/approx/trunk/util.mli 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/util.mli 2005-08-23 21:33:57 UTC (rev 1686)
@@ -57,7 +57,7 @@
(* Return the size of a file *)
-val file_size : string -> int
+val file_size : string -> int64
(* Return the MD5 digest of a file *)
Added: trunk/projects/approx/branches/nethttpd/version.mli
===================================================================
--- trunk/projects/approx/trunk/version.mli 2005-08-23 20:27:57 UTC (rev 1685)
+++ trunk/projects/approx/branches/nethttpd/version.mli 2005-08-23 21:33:57 UTC (rev 1686)
@@ -0,0 +1,2 @@
+val name : string
+val number : string
More information about the Pkg-ocaml-maint-commits
mailing list