helm/graphs/tools/drawGraph.ml

   1 (* Copyright (C) 2002, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 open Printf;;
  27
  28 let debug = true;;
  29 let debug_print s = if debug then prerr_endline s;;
  30
  31 let configuration_file = "/projects/helm/etc/drawGraph.conf.xml";;
  32
  33 let daemon_name = "Draw Graph";;
  34
  35 let wget url fname =
  36   prerr_endline (sprintf "DEBUG: wgetting url '%s'" url);
  37   let oc = open_out fname in
  38   Http_user_agent.get_iter (output_string oc) url;
  39   close_out oc
  40 ;;
  41
  42 let errmsg =
  43   sprintf
  44 "<html>
  45  <head>
  46   <title>Graph: error</title>
  47  </head>
  48  <body>
  49   <h1>Error occurred while drawing graph!<br />Please report the occured problem</h1>
  50   <h2>%s</h2>
  51  </body>
  52 </html>"
  53 in
  54 let string_of_exit_status = function
  55   | Unix.WEXITED n -> sprintf "Process exited with code %d" n
  56   | Unix.WSIGNALED n -> sprintf "Process killed by signal %d" n
  57   | Unix.WSTOPPED n -> sprintf "Process stopped by signal %d" n
  58 in
  59 let callback (req: Http_types.request) outchan =
  60   try
  61     (match req#path with
  62     | "/draw" ->
  63         let url = req#param "url" in
  64         let pid = Unix.getpid () in
  65         wget (sprintf "%s&param.PID=%d" url pid) (sprintf "prova0.%d.dot" pid);
  66         (match Unix.system (sprintf "make tmp PID=%d > log.%d" pid pid) with
  67         | Unix.WEXITED 0 ->
  68             debug_print "HTML successfully generated";
  69             Http_daemon.respond_file (sprintf "prova.%d.html" pid) outchan
  70         | status ->
  71             debug_print "Failure, sending error message";
  72             let res =
  73               new Http_response.response
  74                 ~body:
  75                   (errmsg ("Exit status: " ^ (string_of_exit_status status)))
  76                 ()
  77             in
  78             Http_daemon.respond_with res outchan)
  79     | "/get_gif" ->
  80         let pid = req#param "pid" in
  81         Http_daemon.respond_file (sprintf "prova.%s.gif" pid) outchan;
  82         ignore (Unix.system (
  83           sprintf "make PID=%s clean_tmp; rm -f prova0.%s.dot" pid pid))
  84     | invalid_request ->
  85         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
  86           outchan)
  87   with
  88   | Http_types.Param_not_found attr_name ->
  89       Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
  90         ~body:(sprintf "Parameter '%s' is missing" attr_name)
  91         outchan
  92 in
  93 Helm_registry.load_from configuration_file;
  94 let port = Helm_registry.get_int "draw_graph.port" in
  95 Sys.chdir (Helm_registry.get "draw_graph.dir");
  96 printf "%s started and listening on port %d\n" daemon_name port;
  97 printf "current directory is %s\n" (Sys.getcwd ());
  98 flush stdout;
  99 Http_daemon.start' ~port callback;
 100 printf "%s is terminating, bye!\n" daemon_name
 101