From 227ed314d21d52a2270073bf534eae452732a791 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Mon, 3 Jul 2006 16:59:36 +0000 Subject: [PATCH] Instead of closing the socket to avoid persistent connections (a bugged solution in Ocaml 3.09.2), we use the new ~auto_close feature of libhttp-ocaml. --- daemons/graphs/tools/drawGraph.ml | 9 ++------- daemons/graphs/tools/uriSetQueue.ml | 11 ++--------- daemons/http_getter/main.ml | 8 ++------ daemons/proofChecker/proofChecker.ml | 10 ++-------- daemons/rdfly/rdfly.ml | 9 ++------- daemons/uwobo/uwobo.ml | 10 ++-------- daemons/whelp/searchEngine.ml | 9 ++------- 7 files changed, 14 insertions(+), 52 deletions(-) diff --git a/daemons/graphs/tools/drawGraph.ml b/daemons/graphs/tools/drawGraph.ml index 0dc9800fe..dc6bc42d8 100644 --- a/daemons/graphs/tools/drawGraph.ml +++ b/daemons/graphs/tools/drawGraph.ml @@ -56,7 +56,7 @@ let string_of_exit_status = function | Unix.WSIGNALED n -> sprintf "Process killed by signal %d" n | Unix.WSTOPPED n -> sprintf "Process stopped by signal %d" n in -let callback ((req: Http_types.request), outchan) = +let callback (req: Http_types.request) outchan = try (match req#path with | "/draw" -> @@ -90,18 +90,13 @@ let callback ((req: Http_types.request), outchan) = ~body:(sprintf "Parameter '%s' is missing" attr_name) outchan in -let callback req ch = - HExtlib.finally - (fun () -> try close_out ch with Sys_error _ -> ()) - callback (req, ch) -in Helm_registry.load_from configuration_file; let port = Helm_registry.get_int "draw_graph.port" in Sys.chdir (Helm_registry.get "draw_graph.dir"); printf "%s started and listening on port %d\n" daemon_name port; printf "current directory is %s\n" (Sys.getcwd ()); flush stdout; -let d_spec = Http_daemon.daemon_spec ~port ~callback () in +let d_spec = Http_daemon.daemon_spec ~port ~callback ~auto_close:true () in Http_daemon.main d_spec; printf "%s is terminating, bye!\n" daemon_name diff --git a/daemons/graphs/tools/uriSetQueue.ml b/daemons/graphs/tools/uriSetQueue.ml index 9c94d4e9a..e55fcd214 100644 --- a/daemons/graphs/tools/uriSetQueue.ml +++ b/daemons/graphs/tools/uriSetQueue.ml @@ -76,7 +76,7 @@ let queue_mem item queue = (* mem function over queues *) with Found -> true ;; -let callback ((req: Http_types.request), outchan) = +let callback (req: Http_types.request) outchan = try let res = new Http_response.response () in res#addBasicHeaders; @@ -181,18 +181,11 @@ let callback ((req: Http_types.request), outchan) = outchan in -let callback req ch = - HExtlib.finally - (fun () -> try close_out ch with Sys_error _ -> ()) - callback (req, ch) - -in - Helm_registry.load_from configuration_file; let port = Helm_registry.get_int "uri_set_queue.port" in printf "%s started and listening on port %d\n" daemon_name port; flush stdout; -let d_spec = Http_daemon.daemon_spec ~port ~mode:`Thread ~callback () in +let d_spec = Http_daemon.daemon_spec ~port ~mode:`Thread ~auto_close:true ~callback () in Http_daemon.main d_spec; printf "%s is terminating, bye!\n" daemon_name diff --git a/daemons/http_getter/main.ml b/daemons/http_getter/main.ml index 572e9de1b..199a8b463 100644 --- a/daemons/http_getter/main.ml +++ b/daemons/http_getter/main.ml @@ -263,7 +263,7 @@ let respond_xslt patch_xslt xslt_name outchan = (* thread action *) -let callback ((req: Http_types.request), outchan) = +let callback (req: Http_types.request) outchan = try Http_getter_logger.log ("Connection from " ^ req#clientAddr); Http_getter_logger.log ("Received request: " ^ req#uri); @@ -334,11 +334,6 @@ let callback ((req: Http_types.request), outchan) = log_failure msg; return_html_error ("uncaught_exception", msg) msg outchan) -let callback req outchan = - HExtlib.finally - (fun () -> try close_out outchan with Sys_error _ -> ()) - callback (req, outchan) - let batch_update = ref false let args = [ ] @@ -354,6 +349,7 @@ let main () = let d_spec = Http_daemon.daemon_spec ~mode:`Thread ~timeout:(Some 600) ~port:(Lazy.force Http_getter_env.port) + ~auto_close:true ~callback:callback () in try diff --git a/daemons/proofChecker/proofChecker.ml b/daemons/proofChecker/proofChecker.ml index 928881373..1b3661e34 100644 --- a/daemons/proofChecker/proofChecker.ml +++ b/daemons/proofChecker/proofChecker.ml @@ -92,7 +92,7 @@ let _ = flush !outchan) ;; -let callback ((req : Http_types.request), outchan') = +let callback (req : Http_types.request) outchan' = match req#path with | "/proofCheck" -> begin @@ -125,17 +125,11 @@ let callback ((req : Http_types.request), outchan') = in -let callback req ch = - HExtlib.finally - (fun () -> try close_out ch with Sys_error _ -> ()) - callback (req, ch) - -in printf "Proof Checker started and listening on port %d\n" port; flush stdout; CicEnvironment.set_trust (fun _ -> false); -let d_spec = Http_daemon.daemon_spec ~port ~mode:`Fork ~callback () in +let d_spec = Http_daemon.daemon_spec ~port ~mode:`Fork ~callback ~auto_close:true () in Http_daemon.main d_spec; printf "Proof Checker is terminating, bye!\n" diff --git a/daemons/rdfly/rdfly.ml b/daemons/rdfly/rdfly.ml index 54c87b8d8..8dbb6b051 100644 --- a/daemons/rdfly/rdfly.ml +++ b/daemons/rdfly/rdfly.ml @@ -152,7 +152,7 @@ let password = get_option "rdfly.mysql_connection.password";; let user = get_option "rdfly.mysql_connection.user";; let daemonport = Helm_registry.get_int "rdfly.port";; -let callback ((req: Http_types.request), ch) = +let callback (req: Http_types.request) ch = try debug_print ("Connection from " ^ req#clientAddr) ; debug_print ("Received request: " ^ req#uri) ; @@ -180,16 +180,11 @@ let callback ((req: Http_types.request), ch) = | exc -> return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch -let callback req ch = - HExtlib.finally - (fun () -> try close_out ch with Sys_error _ -> ()) - callback (req, ch) - let main () = Sys.catch_break true; try let d_spec = - Http_daemon.daemon_spec ~timeout:(Some 600) ~port:daemonport ~callback () + Http_daemon.daemon_spec ~timeout:(Some 600) ~port:daemonport ~callback ~auto_close:true () in Http_daemon.main d_spec with Sys.Break -> () diff --git a/daemons/uwobo/uwobo.ml b/daemons/uwobo/uwobo.ml index 7b8a20954..e7aa1e8f9 100644 --- a/daemons/uwobo/uwobo.ml +++ b/daemons/uwobo/uwobo.ml @@ -566,13 +566,6 @@ let callback return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan ;; -let callback - ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan -= - HExtlib.finally - (fun () -> try close_out outchan with Sys_error _ -> ()) - (callback ~syslogger ~styles ~cmd_pipe ~res_pipe () req) outchan - (* UWOBO's startup *) let main () = (* (1) system logger *) @@ -809,7 +802,8 @@ let main () = requests until it will get killed by father *) let d_spec = Http_daemon.daemon_spec ~port ~mode:`Fork - ~callback:(callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) () + ~callback:(callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) + ~auto_close:true () in Http_daemon.main d_spec | _ (* < 0 *) -> (* fork failed :-((( *) diff --git a/daemons/whelp/searchEngine.ml b/daemons/whelp/searchEngine.ml index fc4911619..8524588ca 100644 --- a/daemons/whelp/searchEngine.ml +++ b/daemons/whelp/searchEngine.ml @@ -403,7 +403,7 @@ let exec_action dbd (req: Http_types.request) outchan = ^ " type"))) req outchan -let callback (dbd, (req: Http_types.request), outchan) = +let callback dbd (req: Http_types.request) outchan = try debug_print (sprintf "Received request: %s" req#path); (match req#path with @@ -481,11 +481,6 @@ let callback (dbd, (req: Http_types.request), outchan) = let msg = MooglePp.pp_error "Uncaught exception" exn_string in send_results (`Error msg) req outchan -let callback dbd req ch = - HExtlib.finally - (fun () -> try close_out ch with Sys_error _ -> ()) - callback (dbd, req, ch) - let restore_environment () = match Helm_registry.get_opt Helm_registry.string "search_engine.environment_dump" @@ -519,7 +514,7 @@ let _ = in restore_environment (); read_notation (); - let d_spec = Http_daemon.daemon_spec ~port ~callback:(callback dbd) () in + let d_spec = Http_daemon.daemon_spec ~port ~callback:(callback dbd) ~auto_close:true () in Http_daemon.main d_spec; printf "%s is terminating, bye!\n" daemon_name -- 2.39.2