#! /bin/sh
# (*
exec /opt/godi-3.11-ocamlnet3/bin/ocaml "$0" "$@"
*) directory ".";;

(* $Id: browser.cgi 10 2010-08-02 01:01:07Z gerd $
 * ----------------------------------------------------------------------
 *
 *)

#use "topfind";;
#require "findlib";;
#require "unix";;
#require "str";;
#require "netcgi2";;

(* -CUT- *)

(* ---------------------------------------------------------------------- *)

let buffered_transactional_optype =
  `Transactional (fun config ch -> new Netchannels.buffered_trans_channel ch)

module type CGI = sig val cgi : Netcgi.cgi end

module Body(Cgi : CGI) = struct

  let cgi = Cgi.cgi 

  let param n = (cgi # argument n) # value;;

  let print s = cgi # output # output_string s;;
  
  let cancel() = cgi # output # rollback_work();;
  
  let commit() = cgi # output # commit_work();;

  (* ---------------------------------------------------------------------- *)

  let list_directory d =
    try
      let dd = Unix.opendir d in
      let rec read () =
	try
          let name = Unix.readdir dd in
          if name <> "." & name <> ".." then
            name :: read()
          else
            read()
	with
            End_of_file ->
              Unix.closedir dd;
              []
      in
      read()
    with
	Unix.Unix_error (code,_,_) ->
	  prerr_endline ("Warning: cannot read directory " ^ d ^ ": " ^
			   Unix.error_message code);
	  []
  ;;
  
  
  let all_packages() =
    let l = Fl_package_base.list_packages() in
    Sort.list ( <= ) l
  ;;
  
  
  let modules_of_pkg pkg =
    try
      List.map
	String.capitalize
	(Str.split
	   (Str.regexp "[ \t]*\\([ \t]\\|,\\)[ \t]*")
	   (Findlib.package_property [] pkg "browse_interfaces"))
    with
	Not_found ->
	  let d = Findlib.package_directory pkg in
	  let l = list_directory d in
	  let re = Str.regexp "^\\(.*\\)\\.cmi$" in
	  List.flatten
	    (List.map
	       (fun f ->
		  if Str.string_match re f 0 then
		    [String.capitalize (Str.matched_group 1 f)]
		  else
		    [])
	       l)
  ;;
  
  (* ---------------------------------------------------------------------- *)
  
  let escape_html =
    Netencoding.Html.encode ~in_enc:`Enc_iso88591 ()
  ;;
  
  
  type text =
      Highlighted of string
    | Normal of string
  ;;
  
  
  let read_file path =
    let fd = open_in path in
    let rec read () =
      try
	let line = input_line fd in
	Normal line :: Normal "\n" :: read()
      with
	  End_of_file -> []
    in
    let t = read() in
    close_in fd;
    t
  ;;
  
  
  let rec highlight re t =
    let rec highlight_string s k =
      if k < String.length s then begin
	try
	  let k' = Str.search_forward re s k in
	  let x1 = Normal (String.sub s k (k'-k)) in
	  let x2 = Highlighted (Str.matched_string s) in
	  let x3 = highlight_string s (Str.match_end()) in
	  x1 :: x2 :: x3
	with
	    Not_found ->
	      [ Normal (String.sub s k (String.length s - k)) ]
      end
      else []
    in
    
    match t with
	Highlighted s :: t' -> Highlighted s :: highlight re t'
      | Normal s :: t' ->
	  highlight_string s 0 @ highlight re t'
      | [] ->
	  []
  ;;
  
  
  let rec somewhere_highlighted t =
    match t with
	Normal s :: t' -> somewhere_highlighted t'
      | Highlighted s :: t' -> true
      | [] -> false
  ;;
  
  
  let highlighted_lines t =
    let rec extract this_line t =
      match t with
	  Normal "\n" :: t' ->
	    extract t' t'
	| Normal s :: t' ->
	    extract this_line t'
	| Highlighted s :: t' ->
	    extract_line this_line
	| [] ->
	    []
    and extract_line this_line =
      match this_line with
	  Normal "\n" :: l' -> Normal "\n" :: extract l' l'
	| [] -> []
	| x :: l' -> x :: extract_line l'
    in
    extract t t
  ;;
  
  
  let rec print_text t =
    match t with
	Normal s :: t' ->
	  print (escape_html s);
	  print_text t'
      | Highlighted s :: t' ->
	  print "<font color=\"blue\"><b>";
	  print (escape_html s);
	  print "</b></font>";
	  print_text t'
      | [] ->
	  ()
  ;;
  
  
  (* ---------------------------------------------------------------------- *)
  
  let action() =
    let pkg =
      try
	Str.split (Str.regexp ",") (param "pkg")
      with
	  Not_found -> [] in
    
    let modules =
      try
	Str.split (Str.regexp ",") (param "mod")
      with
	  Not_found -> [] in
    
    let searchmod = try param "searchmod" with Not_found -> "" in
    let searchtext = try param "searchtext" with Not_found -> "" in
    let hlight = try param "hlight" with Not_found -> "" in
    
    let pkg_url p =
      "<a href=\"browser.cgi?" ^ 
	"pkg=" ^ Netencoding.Url.encode p ^
	"\">" ^
	escape_html p ^
	"</a>"
    in
    
    let mod_url p m =
      "<a href=\"browser.cgi?" ^ 
	"pkg=" ^ Netencoding.Url.encode p ^
	"&mod=" ^ Netencoding.Url.encode m ^
	"\">" ^
	escape_html m ^
	"</a>"
    in
    
    let mod_url_hl p m hl =
      "<a href=\"browser.cgi?" ^ 
	"pkg=" ^ Netencoding.Url.encode p ^
	"&mod=" ^ Netencoding.Url.encode m ^
	"&hlight=" ^ Netencoding.Url.encode hl ^
	"\">" ^
	escape_html m ^
	"</a>"
    in
    
    (*** headline ***)
    
    cgi # set_header();
    print "<html><head><title>Objective Caml Packages</title></head>\n";
    print "<body bgcolor=white>\n";
    print "<h1>Objective Caml Packages</h1>\n";
    
    (*** package list ***)
    
    let n_cols = 6 in
    
    let l_packages = all_packages() in
    let packages = Array.of_list l_packages in
    let n = Array.length packages in
    let n_rows = (n-1)/n_cols + 1 in
    
    print "<table>\n";
    for row = 0 to n_rows - 1 do
      print "<tr>\n";
      for col = 0 to n_cols - 1 do
	let k = col * n_rows + row in
	if k < n then begin
	  print "<td>";
	  print (pkg_url packages.(k));
	  print "</td>\n";
	end
      done;
      print "</tr>\n";
    done;
    print "</table>\n";
    
    (*** searched modules ***)
    
    if searchmod <> "" then begin
      print "<h1>Results of module search</h1>\n";
      let l1 = Str.split_delim (Str.regexp "\\*") searchmod in
      let s1 = "^" ^ String.concat ".*" (List.map Str.quote l1) ^ "$" in
      let r1 = Str.regexp_case_fold s1 in
      
      let rec search_pkg pl =
	match pl with
	    [] -> []
	  |	p :: pl' ->
		  let modules = Sort.list ( <= ) (modules_of_pkg p) in
		  let found_modules =
		    List.flatten
		      (List.map
			 (fun m ->
			    if Str.string_match r1 m 0 then [m] else [])
			 modules) in
		  List.map (fun m -> p,m) found_modules
		  @ search_pkg pl'
      in
      
      let result = search_pkg l_packages in
      if result = [] then
	print "Sorry, nothing found.\n"
      else begin
	print "<table>\n";
	List.iter
	  (fun (p,m) ->
	     print "<tr valign=top>\n";
	     print ("<td>Package " ^ pkg_url p ^ "</td>\n");
	     print ("<td>Module " ^ mod_url p m ^ "</td>\n");
	     print "</tr>\n")
	  result;
	print "</table>\n"
      end
    end;
    
    (*** full-text search ***)
    
    if searchtext <> "" then begin
      print "<h1>Results of full-text search</h1>\n";
      let l1 = Str.split_delim (Str.regexp "\\*") searchtext in
      let s1 = String.concat ".*" (List.map Str.quote l1) in
      let r1 = Str.regexp_case_fold s1 in
      
      let rec search_pkg pl =
	match pl with
	    [] -> []
	  | p :: pl' ->
	      let p_dir = Findlib.package_directory p in
	      let modules = Sort.list ( <= ) (modules_of_pkg p) in
	      let found =
		List.flatten
		  (List.map
		     (fun m ->
			let m_file = String.uncapitalize m ^ ".mli" in
			let m_path = Filename.concat p_dir m_file in
			if Sys.file_exists m_path then begin
			  let t = read_file m_path in
			  let t' = highlight r1 t in
			  if somewhere_highlighted t' then
			    let lines = highlighted_lines t' in
			    [p,m,lines]
			  else
			    []
			end
			else [])
		     modules) in
	      found @ search_pkg pl'
      in
      
      let result = search_pkg l_packages in
      if result = [] then
	print "Sorry, nothing found.\n"
      else begin
	print "<table>\n";
	List.iter
	  (fun (p,m,lines) ->
	     print "<tr valign=top>\n";
	     print ("<td>Package " ^ pkg_url p ^ "</td>\n");
	     print ("<td>Module " ^ mod_url_hl p m s1 ^ "</td>\n");
	     print "</tr>\n";
	     print "<tr valign=top>\n";
	     print "<td></td><td><pre>\n";
	     print_text lines;
	     print "</pre></td></tr>\n")
	  result;
	print "</table>\n"
      end
    end;
    
    (*** selected packages ***)
    
    List.iter
      (fun p ->
	 if List.mem p l_packages then begin
	   let p_html = escape_html p in
	   print ("<h1>Package <code>" ^ p_html ^ "</code></h1>\n");
	   
	   let version = 
	     try Findlib.package_property [] p "version" 
	     with Not_found -> "unknown"
	   in
	   let description =
	     try Findlib.package_property [] p "description" 
	     with Not_found -> "none"
	   in
	   let uses_pkg = Findlib.package_ancestors [] p in
	   let pkg_mods = Sort.list ( <= ) (modules_of_pkg p) in
	   print "<table>\n";
	   print "<tr valign=top>\n";
	   print "<td>Version:</td>\n";
	   print ("<td>" ^ escape_html version ^ "</td>\n");
	   print "</tr>\n";
	   print "<tr valign=top>\n";
	   print "<td>Description:</td>\n";
	   print ("<td>" ^ escape_html description ^ "</td>\n");
	   print "</tr>\n";
	   print "<tr valign=top>\n";
	   print "<td>Ancestors:</td>\n";
	   print "<td>";
	   if uses_pkg = [] then
	     print "none"
	   else
	     print (String.concat ", "  (List.map pkg_url uses_pkg));
	   print "</td>\n";
	   print "</tr>\n";
	   print "<tr valign=top>\n";
	   print "<td>Modules:</td>\n";
	   print "<td>";
	   if pkg_mods = [] then
	     print "none"
	   else
	     print (String.concat ", "  (List.map (mod_url p) pkg_mods));
	   print "</td>\n";
	   print "</tr>\n";
	   
	   print "</table>\n";
	 end)
      pkg;
    
    (*** selected modules ***)
    
    if List.length pkg = 1 then begin
      let p = List.hd pkg in
      let p_dir = Findlib.package_directory p in
      List.iter
	(fun m ->
	   let m_html = escape_html m in
	   print ("<h1>Module <code>" ^ m_html ^ "</code></h1>\n");
	   let m_file = String.uncapitalize m ^ ".mli" in
	   let m_path = Filename.concat p_dir m_file in
	   if Sys.file_exists m_path then begin
	     print "<pre>\n";
	     let t = read_file m_path in
	     let t' = 
	       if hlight <> "" then
		 highlight (Str.regexp_case_fold hlight) t
	       else
		 t
	     in
	     print_text t';
	     print "</pre>\n"
	   end
	   else
	     print "Sorry, no printable interface definition found.")
	modules
    end;
    
    (*** search ***)
    
    print "<h1>Search</h1>\n";
    print "You may use <code>*</code> as wildcard character.<br>\n";
    print "<form method=post action=\"browser.cgi\">\n";
    print "<table>\n";
    print "<tr>\n";
    print "<td>Search toplevel module:</td>";
    print "<td><input type=text name=\"searchmod\"></td>";
    print "<td><input type=submit name=\"do_searchmod\" value=\"Go!\"><br></td>\n";
    print "</tr>\n";
    print "<tr>\n";
    print "<td>Full-text search:</td>";
    print "<td><input type=text name=\"searchtext\"></td>";
    print "<td><input type=submit name=\"do_searchtext\" value=\"Go!\"><br></td>\n";
    print "</tr>\n";
    print "</table>\n";
    print "</form>\n";
    
    print "</body></html>\n"
  ;;
  
  begin try
    action()
  with
      e ->
	cgi # set_header();
	print "<html><body><h1>Software error</h1>\n";
	print (Printexc.to_string e);
	print "</body></html>\n";
  end;
  commit()
end

let () =
  Netcgi_cgi.run
    ~output_type:buffered_transactional_optype
    (fun cgi ->
       let module Cgi = struct let cgi = cgi end in
       let module B = Body(Cgi) in
       ()
    )