scripts/visualise_links.ml.

   1 (* COCANWIKI - a wiki written in Objective CAML.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: visualise_links.ml.,v 1.1 2004/10/21 11:42:04 rich Exp $
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2 of the License, or
   9  * (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with this program; see the file COPYING.  If not, write to
  18  * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19  * Boston, MA 02111-1307, USA.
  20  *)
  21
  22 open Apache
  23 open Registry
  24 open Cgi
  25 open Printf
  26
  27 open ExtList
  28
  29 open Cocanwiki
  30 open Cocanwiki_template
  31 open Cocanwiki_files
  32
  33 let rec takepairs = function
  34   | [] -> []
  35   | [x] -> invalid_arg "takepairs: odd number of elements in list"
  36   | x :: y :: xs -> (x, y) :: takepairs xs
  37
  38 let run r (q : cgi) (dbh : Dbi.connection) hostid _ _ =
  39   let template = get_template dbh hostid "visualise_links.html" in
  40
  41   (* This function generates a layout using the 'dot' program, part of
  42    * GraphViz.
  43    *)
  44   let gv_layout () =
  45     let sth = dbh#prepare_cached "select from_url, to_url from links
  46                                    where hostid = ?" in
  47     sth#execute [`Int hostid];
  48
  49     let edges = sth#map (function [`String from_url; `String to_url] ->
  50                            from_url, to_url
  51                            | _ -> assert false) in
  52
  53     let dotfile =
  54       String.concat ""
  55         ([ "digraph t {\n";
  56            "  fill=\"auto\";\n";
  57            "  center=1;\n"; ] @
  58          (List.map (fun (node1, node2) ->
  59                       sprintf "  \"%s\" -> \"%s\";\n" node1 node2)
  60             edges) @
  61          [ "}\n" ]) in
  62
  63     let filename = output_tempfile dotfile in
  64     let cmd = sprintf "dot -Tplain %s" filename in
  65
  66     let lines = pget cmd in
  67     unlink filename;
  68
  69     (* For documentation of the output format of 'dot -Tplain', please see:
  70      * http://www.research.att.com/%7Eerg/graphviz/info/output.html#d:plain
  71      *)
  72     (* Split each line up into fields.  Unfortunately some fields are
  73      * quoted (if they contain spaces or other special characters) so we
  74      * have to deal with that.
  75      *)
  76     let split line =
  77       let n = String.length line in
  78       let rec skip_spaces i =
  79         if i < n && line.[i] = ' ' then skip_spaces (i+1) else i
  80       in
  81       let rec find i c =
  82         if i >= n then -1
  83         else if line.[i] = c then i
  84         else find (i+1) c
  85       in
  86       let rec loop i acc =
  87         if i >= n then acc
  88         else (
  89           let c = line.[i] in
  90           if c = '"' then (             (* quoted field *)
  91             let j = find (i+1) '"' in
  92             let field, i =
  93               if i < j then String.sub line i (j-i), skip_spaces (j+1)
  94               else String.sub line i (n-i), n in
  95             loop i (field :: acc)
  96           ) else (                      (* ordinary field *)
  97             let j = find (i+1) ' ' in
  98             let field, i =
  99               if i < j then String.sub line i (j-i), skip_spaces j
 100               else String.sub line i (n-i), n in
 101             loop i (field :: acc)
 102           )
 103         )
 104       in
 105       List.rev (loop 0 [])
 106     in
 107     let lines = List.map split lines in
 108
 109     (* First line is 'graph'. *)
 110     let graph_line, lines = List.hd lines, List.tl lines in
 111     let width, height =
 112       match graph_line with
 113           [ "graph"; _; width; height ] ->
 114             float_of_string width, float_of_string height
 115         | _ -> assert false in
 116
 117     (* Get the nodes and edges. *)
 118     let is_node = function "node" :: _ -> true | _ -> false in
 119     let is_edge = function "edge" :: _ -> true | _ -> false in
 120     let nodes, edges = List.filter is_node lines, List.filter is_edge lines in
 121
 122     (* Process the nodes and edges. *)
 123     let process_node = function
 124         "node" :: url :: x :: y :: width :: height :: _ ->
 125           url, (float_of_string x, float_of_string y,
 126                 float_of_string width, float_of_string height)
 127       | _ -> assert false
 128     in
 129     let nodes = List.map process_node nodes in
 130
 131     let process_edge = function
 132         "edge" :: node1 :: node2 :: n :: rest ->
 133           let n = int_of_string n in
 134           let points =
 135             List.map (fun (x, y) -> float_of_string x, float_of_string y)
 136               (takepairs (List.take (n*2) rest)) in
 137           node1, node2, points
 138       | _ -> assert false
 139     in
 140     let edges = List.map process_edge edges in
 141
 142     (* Scale the whole thing to 1000x1000 pixel coordinates. *)
 143     let wscale = 1000. /. width in
 144     let hscale = 1000. /. height in
 145
 146     let process_node (url, (x, y, width, height)) =
 147       url, (x *. wscale, y *. hscale, width *. wscale, height *. hscale)
 148     in
 149     let nodes = List.map process_node nodes in
 150
 151     let process_edge (node1, node2, points) =
 152       let process_point (x, y) = x *. wscale, y *. hscale in
 153       node1, node2, List.map process_point points
 154     in
 155     let edges = List.map process_edge edges in
 156
 157     (* Return the layout. *)
 158     let layout = nodes, edges in
 159     layout
 160   in
 161
 162   (* XXX In future we are able to load this from the database. *)
 163   let nodes, edges = gv_layout () in
 164
 165   let table =
 166     List.map (fun (url, (x, y, width, height)) ->
 167                 [ "url", Template.VarString url;
 168                   "x", Template.VarString (string_of_float x);
 169                   "y", Template.VarString (string_of_float y);
 170                   "width", Template.VarString (string_of_float width);
 171                   "height", Template.VarString (string_of_float height) ])
 172       nodes in
 173
 174   template#table "nodes" table;
 175
 176   let table =
 177     List.map (fun (node1, node2, points) ->
 178                 let xpoints, ypoints = List.split points in
 179                 let xpoints =
 180                   List.map (fun x ->
 181                               [ "x", Template.VarString (string_of_float x) ])
 182                     xpoints in
 183                 let ypoints =
 184                   List.map (fun y ->
 185                               [ "y", Template.VarString (string_of_float y) ])
 186                     ypoints in
 187
 188                 [ "node1", Template.VarString node1;
 189                   "node2", Template.VarString node2;
 190                   "xpoints", Template.VarTable xpoints;
 191                   "ypoints", Template.VarTable ypoints; ])
 192       edges in
 193
 194   template#table "edges" table;
 195
 196
 197
 198
 199
 200
 201
 202   q#template template
 203
 204 let () =
 205   register_script ~restrict:[CanEdit] run