helm/interface/xsltProcessor.ml

   1 (* Copyright (C) 2000, 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 exception XsltProcessorCouldNotSend;;
  27 exception XsltProcessorCouldNotReceive;;
  28
  29 let portserver = 12345;;
  30 let portclient = 12346;;
  31 let time_to_wait = 10;;
  32
  33 let rec process uri usecache mode =
  34  let module U = Unix in
  35   let uri = UriManager.string_of_uri uri in
  36   let pid = string_of_int (U.getpid ())
  37   and filename' =
  38    let uri' = Str.replace_first (Str.regexp ".*:") "" uri in
  39     Str.global_replace (Str.regexp "/") "_"
  40      (Str.global_replace (Str.regexp "_") "__" uri')
  41   in let tmpfile = "/tmp/helm_" ^ filename' ^ "_" ^ pid in
  42    (* test if the cache can be used *)
  43    let tmp_file_exists = Sys.file_exists tmpfile in
  44     if usecache && tmp_file_exists then
  45      tmpfile
  46     else
  47      let url = Configuration.getter_url ^ uri in
  48       (* purge the cache if asked to *)
  49       if not usecache && tmp_file_exists then
  50         Sys.remove tmpfile ;
  51       let string_to_send = mode ^ " " ^ url ^ " " ^ tmpfile in
  52       (* next function is for looping in case the server is not responding *)
  53       let rec contact_server () =
  54        let socketclient = U.socket U.PF_INET U.SOCK_DGRAM 0
  55        and socketserver = U.socket U.PF_INET U.SOCK_DGRAM 0 in
  56         let bounded = ref false in
  57          while not !bounded do
  58           try
  59            U.bind socketclient (U.ADDR_INET(U.inet_addr_any,portclient)) ;
  60            bounded := true
  61           with _ ->
  62            print_endline "Port unavailable. Retrying..." ; flush stdout ;
  63            U.sleep 5  (* wait hoping the inetaddr is released *)
  64          done ;
  65          let n =
  66           U.sendto socketserver string_to_send 0 (String.length string_to_send)
  67            [] (U.ADDR_INET(U.inet_addr_any,portserver))
  68          in
  69           if n = -1 then raise XsltProcessorCouldNotSend ;
  70           U.close socketserver ;
  71           let process_signal _ = U.close socketclient in
  72           Sys.set_signal Sys.sigalrm (Sys.Signal_handle process_signal) ;
  73           (* if the server does not respond, repeat the query *)
  74           ignore (U.alarm time_to_wait) ;
  75           try
  76            if U.recv socketclient "" 0 0 [] = -1 then
  77             raise XsltProcessorCouldNotReceive ;
  78            ignore (U.alarm 0) ; (* stop the bomb *)
  79            Sys.set_signal Sys.sigalrm Sys.Signal_default ;
  80            U.close socketclient ;
  81            tmpfile
  82           with
  83            U.Unix_error(_,"recv",_) ->
  84             print_endline "Xaland server not responding. Retrying..." ;
  85             flush stdout;
  86             contact_server ()
  87         in
  88          contact_server ()
  89 ;;