addfile ./Makefile
hunk ./Makefile 1
+#OCDIR = $(shell ocamlc -where)
+#OFLAGS = -I $(OCDIR)/dsf -g -verbose
+
+afn: afn.hs
+	ghc --make -O2 -W afn.hs -o afn
+
+#afn: afn.ml
+#	ocamlc $(OFLAGS) str.cma unix.cma dsf.cma time.ml cgi.ml afn.ml -o $@
+#	cp afn /usr/lib/cgi-bin/afn
+
+mytop: Makefile
+	ocamlmktop $(OFLAGS) str.cma unix.cma dsf.cma time.ml cgi.ml -o mytop
+
+#clean:
+#	rm -f afn *.cm[oaix] *.cmxa
addfile ./afn.hs
hunk ./afn.hs 1
+#!/usr/bin/env runghc
+
+-- This is a CGI script that allows you to link directly to records in the
+-- familysearch.org Ancestral File using the AFN number.
+
+import System.Unix.Process
+import Data.ByteString.Lazy.Char8 (empty, unpack)
+import Data.List (isPrefixOf, tails, find, lookup)
+import Data.Maybe (fromJust)
+import Network.CGI
+import Network.CGI.Protocol (cgiInputs, inputValue)
+import Network.CGI.Monad (cgiGet)
+
+main = runCGI afn
+
+afn :: CGIT IO CGIResult
+afn =
+    do alist <- (cgiGet cgiInputs)
+       let file = inputValue (fromJust (lookup "file_number" alist))
+       (out, _err, _code) <- liftIO $ lazyCommand ("curl -s 'http://www.familysearch.org/Eng/Search/customsearchresults.asp?date_range_index=0&type=0&LDS=0&event_index=0&date_range=0&file_number=" ++ unpack file ++ "&standardize=N&submit=Search&clear=Clear'") empty >>= return . collectOutputUnpacked
+       let uri = maybe Nothing (Just . takeWhile (/= '"')) (find (isPrefixOf "af/individual_record.asp?recid=") (tails out))
+       redirect ("http://www.familysearch.org/Eng/Search/" ++ (fromJust uri))
addfile ./afn.ml
hunk ./afn.ml 1
+(* Given an AFN record name, generate html that redirects us to the
+   family search page for that record.  First we retrieve a web page
+   that contains the recid, then we use that to create the redirect
+   url. *)
+
+(* 
+curl -s 'http://www.familysearch.org/Eng/Search/customsearchresults.asp?date_range_index=0&type=0&LDS=0&event_index=0&date_range=0&file_number=1TF0-QKD&standardize=N&submit=Search&clear=Clear'  ->
+
+af/individual_record.asp?recid=44901677&lds=0&amp;region=%2D1&amp;regionfriendly=&juris1=&juris2=&juris3=&juris4=&regionfriendly=&juris1friendly=&juris2friendly=&juris3friendly=&juris4friendly=
+
+*)
+
+let cgivars = ["file_number", ""]
+
+(* Make a function that returns the value of any cgi variable, 
+   either as passed in the url or the default. *)
+
+let cgi =
+
+  Cgi.cgiinit ();
+
+(*Printf.eprintf "List of CGI arguments:<ul>\n";
+  List.iter
+    (fun (name, arg) -> Printf.eprintf "  %s=%s\n" name arg)
+    (Cgi.arguments ());*)
+
+  let tmp = Hashtbl.create 20 in
+  List.iter (fun (name, defval) ->
+	       Hashtbl.add tmp name
+	       (try Cgi.string_of_cgivar name
+		with Not_found -> defval)) cgivars;
+
+  (* If a submit button was pressed, modify the cgi variable values *)
+  (*
+  List.iter
+    (fun name ->
+       try
+	 let value = Cgi.string_of_cgivar name
+	 and selected_value = List.assoc name buttons in
+	 if value = selected_value then Hashtbl.replace tmp "view" name;
+       with Not_found -> ())
+    cgiinputs; *)
+
+  Hashtbl.find tmp
+
+let new_request_uri =
+  (Unix.getenv "SCRIPT_NAME") ^ "?" ^
+  (String.concat "&"
+     (List.map
+	(fun (key, value) -> key ^ "=" ^ (cgi key))
+	cgivars))
+
+let recid_url_re =
+  Str.regexp "href=['\"]\\(af/individual_record\\.asp\\?recid=[^'\"]*\\)['\"]"
+
+let channel_to_string ichan =
+  let buffer = Buffer.create 16 in
+  try while true do Buffer.add_char buffer (input_char ichan) done; ""
+  with End_of_file -> Buffer.contents buffer
+
+let process_to_string cmd =
+  (*prerr_endline ("process_to_string \"" ^ cmd ^ "\"");*)
+  let ichan = Unix.open_process_in cmd in
+  let html = channel_to_string ichan in
+  ignore (Unix.close_process_in ichan);
+  html
+
+let _ =
+
+  Util.init_backtrace ();
+
+  let file = cgi "file_number" in
+  (*prerr_endline ("\nfile: " ^ file);*)
+  let url =
+    ("curl -s '" ^
+     "http://www.familysearch.org/Eng/Search/customsearchresults.asp?" ^
+     "date_range_index=0&type=0&LDS=0&event_index=0&date_range=0&" ^
+     "file_number=" ^ file ^ "&standardize=N&submit=Search&clear=Clear'") in
+  (*prerr_endline ("url=" ^ url);*)
+  let html = process_to_string url in
+  (*prerr_endline ("html=" ^ html);*)
+
+  print_endline "Content-type: text/html";
+  try
+    begin match html with "" -> raise End_of_file | _ -> () end;
+    let pos = Str.search_forward recid_url_re html 0 in
+    (*prerr_endline (Printf.sprintf "pos=%d" pos);*)
+    let prefix = "http://www.familysearch.org/Eng/Search/" in
+    let url = prefix ^ Str.matched_group 1 html in
+
+    (* If the request URI doesn't include the values of the CGI variables,
+       re-issue the corrected request and exit. *)
+    print_endline ("Location: " ^ url ^ "\n")
+  with
+    End_of_file ->
+      print_endline ("\nCurl process failed\n")
+  | Not_found ->
+      print_endline ("\nCan't find record id:\n<pre>\n" ^ html ^ "</pre>")
addfile ./cgi.ml
hunk ./cgi.ml 1
+exception No_request_method
+exception Unsupported_request_method
+exception No_content_length
+exception No_content_type
+exception Unsupported_content_type
+exception Not_a_hexdigit of char
+exception Not_an_integer of string
+exception Unexpected_CGI_input
+exception Invalid
+
+(* This is some of my earliest ML code.  I think there are easier ways
+   of doing all this. *)
+
+let url_decode string =
+
+  let int_of_hexdigit c =
+    match c with
+      '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 
+    | '5' -> 5 | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 
+    | 'A' -> 10 | 'B' -> 11 | 'C' -> 12 | 'D' -> 13 | 'E' -> 14 | 'F' -> 15
+    | 'a' -> 10 | 'b' -> 11 | 'c' -> 12 | 'd' -> 13 | 'e' -> 14 | 'f' -> 15
+    | _ -> raise (Not_a_hexdigit c) in
+
+  let rec loop pos result =
+    if pos < String.length string then
+      match string.[pos] with
+	'+' -> loop (pos+1) (" " :: result)
+      | '%' -> begin
+	  try
+	    let chr = (char_of_int
+			 ((int_of_hexdigit string.[pos+1]) * 16 +
+			    (int_of_hexdigit string.[pos+2]))) in
+	    loop (pos+3) ((String.make 1 chr) :: result)
+	  with
+	    (Not_a_hexdigit c) -> loop (pos+1) ("%" :: result)
+      end
+      | _ -> loop (pos+1) ((String.make 1 string.[pos]) :: result)
+    else
+      String.concat "" (List.rev result)
+  in loop 0 []
+
+let url_encode s =
+
+  let string_of_char_list l =
+    let s = String.create (List.length l) in
+    let rec loop i l =
+      match l with
+	[] -> s
+      | a::b -> begin s.[i] <- a; loop (i+1) b end
+    in loop 0 l 
+
+  and list_from_string s =
+    let rec loop i l =
+      if (i < 0) then
+	l
+      else
+	loop (i-1) (s.[i] :: l) in
+    loop ((String.length s) - 1) []      
+
+  and hex_from_int i =
+
+    let hexdigit_from_int i =
+      if (i < 10) then
+	char_of_int (i + (int_of_char '0'))
+      else
+	char_of_int ((i - 10) + (int_of_char 'A')) in
+
+    let rec loop i l =
+      if (i = 0) then
+	l
+      else
+	let m = i mod 16
+	and r = i / 16 in
+	loop r ((hexdigit_from_int m) :: l) in
+
+    loop i [] in
+
+  let escape_char c = '%' :: hex_from_int (int_of_char c)
+  and encode_list = ['"';'%';'&';' '] in
+  (* let escape_char c = Printf.sprintf "%%%02X" (Char.code c) *)
+  (* match c with '"' | '%' | '&' | ' ' -> escape_char c | _ -> [c] *)
+  let encode_char c =
+    if (List.memq c encode_list) then escape_char c else [c] in
+  string_of_char_list
+    (List.flatten (List.map encode_char (list_from_string s)))
+
+let cgivars = Hashtbl.create 100
+
+(* If we see -query on the command line set things up so the program 
+   can run in a non-cgi environment. *) 
+
+let status = 
+  let rec loop i status =
+    if i < (Array.length Sys.argv) - 1 then
+      if Sys.argv.(i) = "-query" then begin
+	let query = Sys.argv.(i+1) in
+	Unix.putenv "QUERY_STRING" query;
+	match Str.split (Str.regexp "?") query with
+	  [script_name; parameters] ->
+	    Unix.putenv "HTTP_HOST" "localhost";
+	    Unix.putenv "SCRIPT_NAME" script_name;
+	    Unix.putenv "REQUEST_URI" query;
+	    loop (i+2) false
+	| _ ->
+	    prerr_endline ("Expected <scriptname>?parameters after -query\n" ^
+			   "  saw '" ^ query ^ "'");
+	    assert false;
+(*	    
+	  (try
+	     (Unix.getenv "QUERY_STRING") ^ "&" ^ Sys.argv.(i+1)
+	   with
+	     Not_found -> Sys.argv.(i+1));
+*)
+      end
+      else loop (i+1) status
+    else status in
+  loop 1 true
+
+let _ =
+  if not status then begin
+    Unix.putenv "REQUEST_METHOD" "GET"
+  end
+
+let cgiinit () =
+
+  let string_replace string old nu =
+    let rec loop pos =
+      if pos < String.length string then begin
+	if string.[pos] = old then string.[pos] <- nu;
+	loop (pos+1)
+      end
+    in loop 0
+
+  and amp_regexp = Str.regexp "&"
+  and eq_regexp = Str.regexp "="
+
+  and cgiinput =
+    try
+      match Unix.getenv "REQUEST_METHOD" with
+       (* If this is a GET or HEAD request the cgi variables are
+          appended to the url, and therefore appear here in the
+          environment variable QUERY_STRING. *)
+	"GET" -> (Unix.getenv "QUERY_STRING")
+      |	"HEAD" -> (Unix.getenv "QUERY_STRING")
+
+       (* In a POST request the cgi variables are received via
+	  standard input. *)
+      |	"POST" -> begin
+	  match
+	    try Unix.getenv "CONTENT_TYPE" 
+	    with Not_found -> raise No_content_type
+	  with
+	    "application/x-www-form-urlencoded" -> begin
+	      let n =
+		try int_of_string (Unix.getenv "CONTENT_LENGTH")
+		with Not_found -> raise No_content_length
+	      in
+	      let result = String.create n in
+	      (* Read n characters from standard input *)
+	      ignore (Unix.read (Unix.descr_of_in_channel stdin) result 0 n);
+	      result
+	    end
+	  | _ -> raise Unsupported_content_type
+      end
+      |	_ -> raise Unsupported_request_method;
+    with
+      Not_found -> raise No_request_method
+
+  (* Depending on the request method, read all CGI input into cgiinput
+     (really should produce HTML error messages, instead of exit()ing) *)
+
+  and pairlist =
+    try
+      [ "remote_addr=" ^ (Unix.getenv "REMOTE_ADDR") ]
+    with
+      Not_found -> []
+
+  in
+
+  (* Now split on '&' to extract the name-value pairs into pairlist *)
+  let vars = Str.split_delim amp_regexp cgiinput in
+  let pairs = List.map (Str.split_delim eq_regexp) vars in
+
+  List.iter
+    (fun pr ->
+      match pr with
+	[lhs;rhs] -> Hashtbl.add cgivars lhs (url_decode rhs)
+      | _ -> raise Unexpected_CGI_input)
+    pairs
+
+let cgivar_present key =
+  try ignore(Hashtbl.find cgivars key); true with _ -> false
+
+let list_of_cgivar key = Hashtbl.find_all cgivars key
+
+let string_of_cgivar key =
+  Hashtbl.find cgivars key
+
+let int_of_cgivar key =
+  try
+    int_of_string (string_of_cgivar key)
+  with
+    Failure("int_of_string") -> raise (Not_an_integer (string_of_cgivar key))
+
+let float_of_cgivar key = float_of_string (string_of_cgivar key)
+
+let date_of_cgivar key =
+  Time.date_of_string (string_of_cgivar key)
+
+let arguments () =
+  Hashtbl.fold (fun a v l -> (a, v) :: l) cgivars []
addfile ./time.ml
hunk ./time.ml 1
+exception Bad_month_string of string
+exception Bad_date_string of string
+
+(* Convert date numbers to and from DD-MMM-YY string
+   entry points:
+
+     string_of_date
+     date_of_string
+     secs_from_years
+     years_from_secs *)
+
+let string_of_date date =
+  let months = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";
+		 "Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|]
+  and tm = Unix.gmtime date in
+  ((Printf.sprintf "%2d" tm.Unix.tm_mday)
+   ^ "-" ^ months.(tm.Unix.tm_mon) ^ "-" 
+   ^ (Printf.sprintf "%02d" (tm.Unix.tm_year mod 100)))
+
+let date_of_string date =
+
+  (* I should just encode the months here and be done with it *)
+  let date_re1 = Str.regexp ("^[ \t\n]*\\([0-9]+\\)" ^	(* dd-mmm-yy *)
+			     "[ \t\n-/]*\\([a-zA-Z][a-zA-Z][a-zA-Z]\\)" ^
+			     "[ \t\n-/]*\\([0-9][0-9]+\\)$")
+
+  and date_re2 = Str.regexp ("^[ \t\n]*\\([0-9]+\\)" ^	(* mm-dd-yy *)
+			     "[ \t\n-/]*\\([0-9]+\\)" ^
+			     "[ \t\n-/]*\\([0-9]+\\)$")
+
+  and date_re3 = Str.regexp ("^[ \t\n]*$")		(* Right now *)
+
+  and int_of_monthname string =
+    match string with
+      "Jan" -> 0 | "Feb" -> 1 | "Mar" -> 2 | "Apr" -> 3
+    | "May" -> 4 | "Jun" -> 5 | "Jul" -> 6 | "Aug" -> 7
+    | "Sep" -> 8 | "Oct" -> 9 | "Nov" -> 10 | "Dec" -> 11
+    | _ -> raise (Bad_month_string string)
+
+  and mkdate mday mon year =
+    match Unix.mktime { Unix.tm_sec = 0;
+			Unix.tm_min = 0;
+			Unix.tm_hour = 12;
+			Unix.tm_mday = mday;
+			Unix.tm_mon = mon;
+			Unix.tm_wday = 0;	(* Don't care? *)
+			Unix.tm_year = year;
+			Unix.tm_yday = 0;	(* Don't care? *)
+			Unix.tm_isdst = false } with
+      secs, tm -> secs
+
+  and int_of_year year = 
+    let year = int_of_string year in
+    if (year < 50) then year + 100
+    else if (year > 1000) then year - 1900
+    else year
+
+  in
+
+  (* Convert to number of years since 1900.  Assume 00 means 2000, 49
+     means 2049, 50 means 1950, 99 means 1999.  Anything over 1000 is
+     used as-is. *)
+
+  if (Str.string_match date_re3 date 0) then
+    (Unix.gettimeofday ())
+  else if (Str.string_match date_re1 date 0) then
+    (mkdate
+       (int_of_string (Str.matched_group 1 date))
+       (int_of_monthname (Str.matched_group 2 date))
+       (int_of_year (Str.matched_group 3 date)))
+  else if (Str.string_match date_re2 date 0) then
+    (mkdate
+       (int_of_string (Str.matched_group 2 date))
+       ((int_of_string (Str.matched_group 1 date)) - 1)
+       (int_of_year (Str.matched_group 3 date)))
+  else raise (Bad_date_string date)
+
+let secs_from_years years = years *. 31557600.0
+let years_from_secs secs = secs /. 31557600.0
+
+let year_of_date date = int_of_float ((years_from_secs date) +. 1970.0)
addfile ./top.ml
hunk ./top.ml 1
+#load "unix.cma"
+#load "str.cma"
+#use "time.ml"
+#use "cgi.ml"
addfile ./whstatus.ml
hunk ./whstatus.ml 1
+(* Views:
+
+   1) package | section | dist1 | dist2 | dist3 |
+      --------+---------+-------+-------+-------+
+       name   |  main   |version|version|version|
+*)
+
+let root = "/build/packages/cnr-webdev/fullpool"
+let sources = 
+  ["lindowsos", "stable", ["main", ["i386"];
+			   "contrib", ["i386"];
+			   "non-free", ["i386"];
+			   "kde3", ["i386"]];
+   "lindowsos", "testing", ["main", ["i386"];
+			    "contrib", ["i386"];
+			    "non-free", ["i386"];
+			    "kde3", ["i386"]];
+   "lindowsos", "unstable", ["main", ["i386"];
+			     "contrib", ["i386"];
+			     "non-free", ["i386"];
+			     "kde3", ["i386"]]]
+
+let version_table () =
+
+  let dists = ["stable"; "testing"; "unstable"] in
+  let table =
+    let tmp = Hashtbl.create 10000 in
+    Debian.iter_packages_of_sources
+      (fun (pool, dist, sect, arch, url, control) ->
+	 let name = Util.tassoc "Package" control
+	 and version = Util.tassoc "Version" control in
+	 Hashtbl.replace tmp name ((sect, dist, version) :: 
+				     (try Hashtbl.find tmp name
+				      with Not_found -> [])))
+      root sources;
+    tmp in
+
+  print_endline "<table cellpadding=0 cellspacing=0 border=0 align=center>";
+
+  let row = ref "even" in
+  let values =
+    let tmp = ref [] in
+    Hashtbl.iter (fun key value -> tmp := (key, value) :: !tmp) table;
+    List.sort (fun (n1, _) (n2, _) -> compare n1 n2) !tmp in
+  print_endline
+    ("<tr><th>package<th>" ^ (String.concat "<th>" dists) ^ "</tr>");
+
+  let rowtext name lst =
+    let alist =
+      List.map (fun (sect, dist, version) -> (dist, version)) lst in
+    let versions = List.map (fun dist ->
+			       try List.assoc dist alist
+			       with Not_found -> "") dists in
+    (* Replace the empty strings with the version number of 
+       the more stable distribution *)
+    let versions' =
+      List.rev
+	(List.fold_left
+	   (fun result b ->
+	      match result with
+		a :: etc ->
+		  if b = ""
+		  then a :: result
+		  else b :: result
+	      | [] -> [b])
+	   [] versions) in
+
+    (* If a less stable version has an older version, mark it red.
+       If a less stable version has the same version print a left
+       arrow. *)
+
+    let versions'' =
+      let rec loop lst =
+	match lst with
+	  a :: b :: etc ->
+	    let a' = 
+	      if a <> "" && a = b
+	      then "&lt;-"
+	      else if Debian.version_compare a b < 0
+	      then "<FONT color=#ff0000>" ^ a ^ "</FONT>"
+	      else a in
+	    a' :: loop (b :: etc)
+	| _ -> lst in
+      List.rev (loop (List.rev versions')) in
+
+    "<td>" ^ name ^ "<td>" ^ (String.concat "<td>" versions'') in
+  
+  List.iter
+    (fun (name, lst) ->
+       row := if !row = "even" then "odd" else "even";
+       print_endline ("<tr class=" ^ !row ^ ">" ^
+		      (rowtext name lst) ^ "</tr>"))
+    values;
+
+  print_endline "</table>\n"
+
+let db_table () =
+
+  let dblabels = ["live"; "testing"; "unstable"]
+  and dbname = Some "lindows" in
+  let dbhosts = 
+    List.map (function
+		  "live" -> "10.0.0.70"
+		| "testing" -> "65.241.11.124"
+		| "unstable" -> "65.241.11.24"
+		| _ -> assert false) dblabels in
+
+  let dblst = 
+    List.map (fun host ->
+		Db.connect {Db.typ = Db.MysqlDB;
+			    Db.host = Some host;
+			    Db.name = dbname;
+			    Db.port = None;
+			    Db.pwd = Some "ocaml";
+			    Db.user = Some "warehouse"}) dbhosts in
+
+  let query = 
+    Db.Select
+      ("applications",
+       [|"serialnumber"; "package_name"; "version"|],
+       Db.TRUE) in
+  let reslist =
+    List.map (fun db -> Db.command db query) dblst in
+  let tables = List.map (fun res -> Hashtbl.create 10000) reslist in
+  let names = Hashtbl.create 10000 in
+  List.iter2 (fun res table ->
+		Db.iter
+		(function
+		     [|Db.Int sn; Db.Str pn; Db.Str v|] as tuple ->
+		       Hashtbl.add table pn tuple;
+		       Hashtbl.replace names pn ()
+		   | [|Db.Int sn; Db.Null; _|] as tuple ->
+		       ()
+		   | [|Db.Int sn; Db.Str pn; Db.Null|] ->
+		       ()
+		   | other ->
+		       Message.vq_nl ("Bad row: " ^ (String.concat " " (List.map Db.value_name (Array.to_list other))));
+		       assert false)
+		res) reslist tables;
+  let names = List.sort compare
+    (let tmp = ref [] in
+     Hashtbl.iter (fun name _ -> tmp := name :: !tmp) names; !tmp) in
+  print_endline "<table cellpadding=0 cellspacing=0 border=0 align=center>";
+  print_endline ("<tr><th>package<th>" ^
+		 (String.concat "<th>" dblabels) ^ "</tr>");
+    
+  List.iter
+    (fun name ->
+       print_string ("<tr><td>" ^ name);
+       let infolst = List.map (fun table ->
+			      try Some (Hashtbl.find table name)
+			      with Not_found -> None) tables in
+       List.iter
+	 (function
+	      Some [|Db.Int sn; _; Db.Str v|] ->
+		print_string ("<td>" ^ v ^ " (id=" ^ (string_of_int sn) ^ ")");
+	    | None ->
+		print_string "<td>"
+	    | _ ->
+		assert false)
+	 infolst;
+       print_endline "</tr>")
+    names;
+
+  print_endline "</table>\n"
+	   
+let _ =
+  (* Header *)
+  print_endline "Content-type: text/html";
+  (* If the request URI doesn't include the values of the CGI variables,
+     re-issue the corrected request and exit. *)
+  if Params.new_request_uri <> Unix.getenv "REQUEST_URI"
+  then begin
+    print_endline
+      ("Location: " ^ "http://" ^ (Unix.getenv "HTTP_HOST") ^
+       Params.new_request_uri ^ "\n");
+    raise Exit
+  end
+  else
+    print_newline ();	(* End of header *)
+
+  print_string "<html>\n";
+  Report.print_style ();
+  flush stdout;		(* Should clear the window *)
+  (*version_table ();*)
+  db_table ();
+  print_string "</html>\n"