From: Stefano Zacchiroli Date: Tue, 19 Nov 2002 16:05:25 +0000 (+0000) Subject: added ocaml version of draw_graph and uri_set_queue X-Git-Tag: V_0_0_5~34 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=4c67cc0208078e3952a5146563d4d49116f7edf4;p=helm.git added ocaml version of draw_graph and uri_set_queue --- diff --git a/helm/graphs/tools/.cvsignore b/helm/graphs/tools/.cvsignore new file mode 100644 index 000000000..a9c3ad4a1 --- /dev/null +++ b/helm/graphs/tools/.cvsignore @@ -0,0 +1,7 @@ +*.cm[iaox] +*.[ao] +*.cmxa +drawGraph +uriSetQueue +drawGraph.opt +uriSetQueue.opt diff --git a/helm/graphs/tools/Makefile b/helm/graphs/tools/Makefile index 0635c4c26..8246a81da 100644 --- a/helm/graphs/tools/Makefile +++ b/helm/graphs/tools/Makefile @@ -2,11 +2,27 @@ PID= DOT=../gv1.7c/bin/dot SED=sed "s/font-family:Times;//g" +REQUIRES = http +PREDICATES = +OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" +OCAMLC = ocamlfind ocamlc $(OCAMLOPTIONS) +OCAMLOPT = ocamlfind ocamlopt $(OCAMLOPTIONS) + #OBJS=prova.$(PID).svg prova.$(PID).ps prova.$(PID).gif prova.$(PID).ismap prova.$(PID).imap prova.$(PID).html OBJS=prova.$(PID).gif prova.$(PID).ismap prova.$(PID).html all: $(OBJS) +uriSetQueue: uriSetQueue.ml + $(OCAMLC) -linkpkg -o $@ $< +uriSetQueue.opt: uriSetQueue.ml + $(OCAMLOPT) -linkpkg -o $@ $< + +drawGraph: drawGraph.ml + $(OCAMLC) -package "unix netclient" -linkpkg -o $@ $< +drawGraph.opt: drawGraph.ml + $(OCAMLOPT) -package "unix netclient" -linkpkg -o $@ $< + prova.$(PID).dot: prova0.$(PID).dot csplit --prefix=xx.$(PID) prova0.$(PID).dot 1 2 `expr \`wc -l prova0.$(PID).dot | sed 's/\([0123456789]\+\) prova0.$(PID).dot/\1/'\` + 1` ./simplify_deps/simplify_deps.opt < xx.$(PID)02 > xx.$(PID)02n diff --git a/helm/graphs/tools/drawGraph.ml b/helm/graphs/tools/drawGraph.ml new file mode 100644 index 000000000..5c539c1c2 --- /dev/null +++ b/helm/graphs/tools/drawGraph.ml @@ -0,0 +1,80 @@ + +(* Copyright (C) 2002, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +open Printf;; + +let daemon_name = "Draw Graph";; +let default_port = 48083;; +let port_env_var = "DRAW_GRAPH_PORT";; + +let wget url fname = + let data = Http_client.Convenience.http_get url in + let oc = open_out fname in + output_string oc data; + close_out oc +;; + +let port = + try + int_of_string (Sys.getenv port_env_var) + with + | Not_found -> default_port + | Failure "int_of_string" -> + prerr_endline "Warning: invalid port, reverting to default"; + default_port +in +let callback req outchan = + try + (match req#path with + | "/draw" -> + let url = req#param "url" in + let pid = Unix.getpid () in + wget (sprintf "%s¶m.PID=%d" url pid) (sprintf "prova0.%d.dot" pid); + (match Unix.system (sprintf "make PID=%d > log.%d" pid pid) with + | Unix.WEXITED 0 -> + Http_daemon.respond_file (sprintf "") outchan + | _ -> + Http_daemon.respond_error + ~status:(`Server_error `Internal_server_error) outchan) + | "/get_gif" -> + let pid = req#param "pid" in + Http_daemon.respond_file (sprintf "prova.%s.gif" pid) outchan; + ignore (Unix.system ( + sprintf "make PID=%s clean; rm -f prova0.%s.dot" pid pid)) + | invalid_request -> + Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan) + with + | Http_request.Param_not_found attr_name -> + Http_daemon.respond_error + ~status:(`Client_error `Bad_request) + ~body:(sprintf "Parameter '%s' is missing" attr_name) + outchan +in +printf "%s started and listening on port %d\n" daemon_name port; +flush stdout; +Http_daemon.start' ~port callback; +printf "%s is terminating, bye!\n" daemon_name + diff --git a/helm/graphs/tools/draw_graph.cgi b/helm/graphs/tools/draw_graph.cgi index 24170593f..e807d97e0 100755 --- a/helm/graphs/tools/draw_graph.cgi +++ b/helm/graphs/tools/draw_graph.cgi @@ -25,28 +25,28 @@ while (my $c = $d->accept) { my $http_query = $r->url->equery; my $cgi = new CGI("$http_query"); my $url = $cgi->param('url'); - $url = $url.'¶m.PID='.$$; - print "URL: $url\n"; + $url = $url.'¶m.PID='.$$; + print "URL: $url\n"; my $ua = LWP::UserAgent->new; my $request = HTTP::Request->new(GET => "$url"); my $response = $ua->request($request, "prova0.$$.dot"); - if (system("make PID=$$ > log.$$") == 0) { + if (system("make PID=$$ > log.$$") == 0) { $c->send_file_response("prova.$$.html"); - } else { - $c->send_error(RC_INTERNAL_SERVER_ERROR); - } + } else { + $c->send_error(RC_INTERNAL_SERVER_ERROR); + } } elsif ($r->method eq 'GET' && $r->url->path eq "/get_gif") { my $http_query = $r->url->equery; my $cgi = new CGI("$http_query"); my $pid = $cgi->param('pid'); - print "Returning GIF: $pid\n"; + print "Returning GIF: $pid\n"; $c->send_file_response("prova.$pid.gif"); - system("make PID=$pid clean ; rm -f prova0.$pid.dot"); + system("make PID=$pid clean ; rm -f prova0.$pid.dot"); } elsif ($r->method eq 'GET' && $r->url->path eq "/help"){ print "Help requested!\n"; - my $response = new HTTP::Response; + my $response = new HTTP::Response; $response->content("Graph Drawer Version: ???"); $c->send_response($response); } else { diff --git a/helm/graphs/tools/uriSetQueue.ml b/helm/graphs/tools/uriSetQueue.ml new file mode 100644 index 000000000..2ce17a141 --- /dev/null +++ b/helm/graphs/tools/uriSetQueue.ml @@ -0,0 +1,162 @@ +(* Copyright (C) 2002, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +open Printf;; + +let daemon_name = "Uri Set Queue";; +let default_port = 48082;; +let port_env_var = "URI_SET_QUEUE_PORT";; + +type uri_queue = { + mutable size: int; + mutable overflowed: bool; + uris: string Queue.t; +} + (** raised when a queue is accessed before being defined *) +exception Queue_not_found of int;; + (** global uri_queue, used by all children *) +let uri_queue = { size = 0; overflowed = false; uris = Queue.create () };; +let (get_queue, add_queue, remove_queue) = + let uri_queues = Hashtbl.create 17 in + ((fun pid -> (* get_queue *) + try + Hashtbl.find uri_queues pid + with Not_found -> raise (Queue_not_found pid)), + (fun pid size -> (* add_queue *) + Hashtbl.replace + uri_queues + pid + { size = size; overflowed = false; uris = Queue.create () }), + (fun pid -> (* remove_queue *) + try + Hashtbl.remove uri_queues pid + with Not_found -> raise (Queue_not_found pid))) +;; + +exception Found;; +let queue_mem item queue = (* mem function over queues *) + try + Queue.iter (fun e -> if item = e then raise Found) queue; + false + with Found -> true +;; + +let port = + try + int_of_string (Sys.getenv port_env_var) + with + | Not_found -> default_port + | Failure "int_of_string" -> + prerr_endline "Warning: invalid port, reverting to default"; + default_port +in +let callback req outchan = + try + let res = new Http_response.response in + res#addBasicHeaders; + res#setContentType "text/xml"; + (match req#path with + + | "/add_if_not_in" -> + let (uri, pid) = (req#param "uri", int_of_string (req#param "PID")) in + let queue = get_queue pid in + let result = + if not (queue_mem uri queue.uris) then begin (* uri not in *) + if Queue.length queue.uris >= queue.size then begin (* overflow! *) + queue.overflowed <- true; + "not_added_because_already_too_many" + end else begin (* add the uri *) + Queue.add uri queue.uris; + "added" + end + end else (* url already in *) + "already_in" + in + res#setContents (sprintf "<%s/>\n" result); + Http_daemon.respond_with res outchan + + | "/is_overflowed" -> + let pid = int_of_string (req#param "PID") in + let queue = get_queue pid in + let result = string_of_bool (queue.overflowed) in + res#setContents (sprintf "<%s/>\n" result); + Http_daemon.respond_with res outchan + + | "/set_uri_set_size" -> + let (pid, size) = + (int_of_string (req#param "PID"), int_of_string (req#param "size")) + in + (try + let queue = get_queue pid in + queue.size <- size; + with Queue_not_found p -> + assert (p = pid); + add_queue pid size); + res#setContents "\n\n"; + Http_daemon.respond_with res outchan + + | "/get_next" -> + let pid = int_of_string (req#param "PID") in + let queue = get_queue pid in + let element = (* xml response's root element *) + try + let uri = Queue.take queue.uris in + sprintf + "<%suri value=\"%s\"/>" + (if queue.overflowed then "marked_" else "") + uri + with Queue.Empty -> "" + in + res#setContents ("" ^ element ^ "\n"); + Http_daemon.respond_with res outchan + + | "/reset_to_empty" -> + let pid = int_of_string (req#param "PID") in + remove_queue pid; + res#setContents "\n\n"; + Http_daemon.respond_with res outchan + + | invalid_request -> + Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan) + with + | Http_request.Param_not_found attr_name -> + Http_daemon.respond_error + ~status:(`Client_error `Bad_request) + ~body:(sprintf "Parameter '%s' is missing" attr_name) + outchan + | Failure "int_of_string" -> (* error in converting some paramters *) + Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan + | Queue_not_found queue_name -> + Http_daemon.respond_error + ~status:(`Client_error `Bad_request) + ~body:(sprintf "Queue '%d' is not defined" queue_name) + outchan +in + +printf "%s started and listening on port %d\n" daemon_name port; +flush stdout; +Http_daemon.start' ~port ~fork:false callback; +printf "%s is terminating, bye!\n" daemon_name +