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 daemon_name = "Draw Graph";;
  32 let default_port = 48083;;
  33 let default_dir = "/projects/helm/graphs/tools";;
  34 let port_env_var = "DRAW_GRAPH_PORT";;
  35 let dir_env_var = "DRAW_GRAPH_DIR";;
  36
  37 let wget url fname =
  38   prerr_endline (sprintf "DEBUG: wgetting url '%s'" url);
  39   let oc = open_out fname in
  40   Http_client.http_get_iter (output_string oc) url;
  41   close_out oc
  42 ;;
  43
  44 let port =
  45   try
  46     int_of_string (Sys.getenv port_env_var)
  47   with
  48   | Not_found -> default_port
  49   | Failure "int_of_string" ->
  50       prerr_endline "Warning: invalid port, reverting to default";
  51       default_port
  52 in
  53 let dir = try Sys.getenv dir_env_var with Not_found -> default_dir in
  54 let errmsg =
  55   sprintf
  56 "<html>
  57  <head>
  58   <title>Graph: error</title>
  59  </head>
  60  <body>
  61   <h1>Error occurred while drawing graph!<br />Please report the occured problem</h1>
  62   <h2>%s</h2>
  63  </body>
  64 </html>"
  65 in
  66 let string_of_exit_status = function
  67   | Unix.WEXITED n -> sprintf "Process exited with code %d" n
  68   | Unix.WSIGNALED n -> sprintf "Process killed by signal %d" n
  69   | Unix.WSTOPPED n -> sprintf "Process stopped by signal %d" n
  70 in
  71 let callback (req: Http_types.request) outchan =
  72   try
  73     (match req#path with
  74     | "/draw" ->
  75         let url = req#param "url" in
  76         let pid = Unix.getpid () in
  77         wget (sprintf "%s&param.PID=%d" url pid) (sprintf "prova0.%d.dot" pid);
  78         (match Unix.system (sprintf "make tmp PID=%d > log.%d" pid pid) with
  79         | Unix.WEXITED 0 ->
  80             debug_print "HTML successfully generated";
  81             Http_daemon.respond_file (sprintf "prova.%d.html" pid) outchan
  82         | status ->
  83             debug_print "Failure, sending error message";
  84             let res =
  85               new Http_response.response
  86                 ~body:
  87                   (errmsg ("Exit status: " ^ (string_of_exit_status status)))
  88                 ()
  89             in
  90             Http_daemon.respond_with res outchan)
  91     | "/get_gif" ->
  92         let pid = req#param "pid" in
  93         Http_daemon.respond_file (sprintf "prova.%s.gif" pid) outchan;
  94         ignore (Unix.system (
  95           sprintf "make PID=%s clean_tmp; rm -f prova0.%s.dot" pid pid))
  96     | invalid_request ->
  97         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
  98   with
  99   | Http_types.Param_not_found attr_name ->
 100       Http_daemon.respond_error
 101         ~status:(`Client_error `Bad_request)
 102         ~body:(sprintf "Parameter '%s' is missing" attr_name)
 103         outchan
 104 in
 105 Sys.chdir dir;
 106 printf "%s started and listening on port %d\n" daemon_name port;
 107 printf "current directory is %s\n" (Sys.getcwd ());
 108 flush stdout;
 109 Http_daemon.start' ~port callback;
 110 printf "%s is terminating, bye!\n" daemon_name
 111