Below is the file 'database-mt.ml' from this revision. You can also download the file.

open Viz_misc
open Viz_types

let () = Sqlite3.init

let monot_encode s = Base64.encode ~linelength:72 s
let monot_decode s = Base64.decode ~accept_spaces:true s

let sql_escape s =
  String.concat "''" (string_split ~collapse:false '\'' s)

let register_base64_functions db =
  if Viz_misc.debug "sql"
  then
    Sqlite3.trace_set db
      (fun s -> prerr_string "### sql: " ; prerr_endline s) ;
  Sqlite3.create_fun_1 db "unbase64" (fun s -> `TEXT (monot_decode (Sqlite3.value_text s)))

let fetch_pubkeys db tbl =
  Sqlite3.fetch db
    "SELECT id, keydata, ROWID FROM public_keys"
    (fun () -> function
      | [| id; data; rowid |] ->
	  begin
	    try
	      let key = Crypto.decode_rsa_pubkey (monot_decode data) in
	      Hashtbl.add tbl id (key, int_of_string rowid - 1)
	    with Failure _ -> ()
	  end
      | _ -> ())
    ()

let fetch_branches db =
  List.sort compare
    (Sqlite3.fetch db
       "SELECT DISTINCT value FROM revision_certs WHERE name = 'branch'"
       (fun acc row -> monot_decode row.(0) :: acc)
       [])

let view_name = "ids_of_branch"

let bool_of_sql_string s = s <> "0"

let id_set_add_if t v s =
  if t then IdSet.add v s else s

let add_node id in_set rel_id rel nodes =
  if id = "" then nodes else begin
    let current_node =
      try NodeMap.find id nodes
      with Not_found ->
	{ id = id ;
	  kind = if in_set then REGULAR else NEIGHBOUR ;
	  family = [] } in
    let new_node =
      if rel_id <> "" && not (List.mem_assoc rel_id current_node.family)
      then { current_node with family = (rel_id, rel) :: current_node.family }
      else current_node in
    NodeMap.add id new_node nodes
  end

let process_ancestry_row g = function
  | [| parent; parent_mem; child; child_mem |] ->
      let parent_mem = bool_of_sql_string parent_mem in
      let child_mem = bool_of_sql_string child_mem in
      { nodes    = (add_node parent parent_mem child CHILD (
		    add_node child child_mem parent PARENT g.nodes)) ;

	ancestry =
	if parent <> "" && child <> ""
	then
	  EdgeMap.add (parent, child)
	    (if parent_mem && child_mem then SAME_BRANCH else BRANCHING)
	    g.ancestry
	else g.ancestry ;

	neighbour_nodes = (id_set_add_if (not parent_mem) parent (
			   id_set_add_if (not child_mem) child
			     g.neighbour_nodes)) }
  | _ -> g

let auto_cl_re = [
  Str.regexp "\\(\\(explicit_\\)?merge of\\|propagate \\(of\\|from\\)\\) ", MERGE ;
  Str.regexp "disapproval of ", DISAPPROVE
]
let re_match s (re, _) = Str.string_match re s 0

let process_changelog_row g = function
  | [| id; cl |] ->
      let cl = monot_decode cl in
      if not (List.exists (re_match cl) auto_cl_re)
      then g else begin
	let (_, kind) = List.find (re_match cl) auto_cl_re in
	let node =
	  try NodeMap.find id g.nodes
	  with Not_found -> assert false (* monotone db is inconsistent *) in
	let updated_edges =
	  if kind = DISAPPROVE
	  then begin
	    let pid =
	      try list_rassoc PARENT node.family
	      with Not_found -> assert false in
	    let a = EdgeMap.add (pid, id) DISAPPROVED g.ancestry in
	    try
	      let pnode = NodeMap.find pid g.nodes in
	      let gpid = list_rassoc PARENT pnode.family in
	      EdgeMap.add (gpid, pid) DISAPPROVED a
	    with Not_found -> a
	  end
	  else g.ancestry in
	let updated_nodes =
	  if kind <> node.kind
	  then NodeMap.add id { node with kind = kind } g.nodes
	  else g.nodes in
	{ g with ancestry = updated_edges ; nodes = updated_nodes }
      end
  | _ -> g


let process_branching_edge_row g = function
  | [| parent; child |] ->
      { g with ancestry = EdgeMap.add (parent, child) BRANCHING g.ancestry }
  | _ -> g


let fetch_agraph_with_view db query =
  let agraph = Viz_types.empty_agraph in

  (* grab all node ids and edges we're interested in *)
  let agraph =
    Sqlite3.fetch_f db process_ancestry_row agraph
      "SELECT parent, parent IN %s, child, child IN %s FROM revision_ancestry \
        WHERE parent IN %s OR child IN %s" view_name view_name view_name view_name in

  (* look at changelogs to decide what nodes are 'uninteresting'
     (ie merge or disapproval nodes) *)
  let agraph =
    Sqlite3.fetch_f db process_changelog_row agraph
      "SELECT id, value FROM revision_certs WHERE name = 'changelog' AND id IN %s"
      view_name in

  (* determine the branching edges *)
  let agraph =
    begin
      match query with
      | BRANCH _ ->
          (* we already have the branching edges *)
	  agraph
      | _ ->
	  (* we need another database query *)
	  Sqlite3.fetch_f db
	    process_branching_edge_row agraph
	    "SELECT A.parent, A.child \
               FROM revision_ancestry AS A, revision_certs AS C, revision_certs AS P \
              WHERE (C.id IN %s OR P.id IN %s) AND \
                    C.id = A.child AND P.id = A.parent AND \
                    C.name = 'branch' AND P.name = 'branch' AND \
                    C.value != P.value"
	    view_name view_name
    end in

  agraph


let fetch_with_view query db f =
  Viz_misc.bracket
    ~before:(fun () ->
      (* We fetch the ids matching the query (ie those on certain branches) *)
      (* and store them in a view. *)
      Sqlite3.exec db
	begin
	  match query with
	  | ALL -> Printf.sprintf
		"CREATE TEMP VIEW %s AS \
                 SELECT DISTINCT id FROM revision_certs" view_name
	  | BRANCH branch -> Printf.sprintf
		"CREATE TEMP VIEW %s AS \
		 SELECT DISTINCT id FROM revision_certs \
                  WHERE name = 'branch' AND value = '%s'"
		view_name (monot_encode branch)
	  | COLLECTION branch -> Printf.sprintf
		"CREATE TEMP VIEW %s AS \
		 SELECT DISTINCT id FROM revision_certs \
                  WHERE name = 'branch' AND unbase64(value) LIKE '%s%%'"
		view_name (sql_escape branch)
	end)
    ~action:(fun () -> f db query)
    ~after:(fun () -> Sqlite3.exec_f db "DROP VIEW %s" view_name)
    ()

let fetch_agraph query db =
  fetch_with_view query db fetch_agraph_with_view

let decode_and_parse_revision s =
  Revision_parser.revision_set
    Revision_lexer.lex
    (Lexing.from_string
       (Unzip.inflate_str ~kind:Unzip.GZip (monot_decode s)))

let fetch_revision_set db id =
  decode_and_parse_revision
    (List.hd
       (Sqlite3.fetch_f db (fun acc row -> row.(0) :: acc) []
	  "SELECT data FROM revisions WHERE id = '%s'" id))

let verify_cert_sig pubkeys keypair name id v signature =
  try
    let (pubkey, _) = Hashtbl.find pubkeys keypair in
    if Crypto.rsa_sha1_verify pubkey
	(Printf.sprintf "[%s@%s:%s]" name id (Base64.encode v))
	signature
    then SIG_OK
    else SIG_BAD
  with Not_found -> SIG_UNKNOWN

let process_certs pubkeys acc = function
  | [| id; name; v; keypair; signature |] ->
      let dec_v = monot_decode v in
      let dec_sig = monot_decode signature in
      { c_id = id ;
	c_name = name ;
	c_value = dec_v ;
	c_signer_id = keypair ;
	c_signature = verify_cert_sig pubkeys keypair name id dec_v dec_sig } :: acc
  | _ -> acc

let fetch_certs db pubkeys id =
  Sqlite3.fetch_f db (process_certs pubkeys) []
    "SELECT id, name, value, keypair, signature \
       FROM revision_certs WHERE id = '%s'" id

let fetch_one_cert_field db id name = function
  | `VALUE ->
    Sqlite3.fetch_f db (fun acc row -> monot_decode row.(0) :: acc) []
      "SELECT value \
       FROM revision_certs WHERE id = '%s' AND name = '%s'" id (sql_escape name)
  | `SIGNER ->
    Sqlite3.fetch_f db (fun acc row -> row.(0) :: acc) []
      "SELECT keypair \
       FROM revision_certs WHERE id = '%s' AND name = '%s'" id (sql_escape name)


let spawn_monotone_diff db_fname monotone_exe (old_id, new_id) status cb =
  let cmd = [ monotone_exe ;
	      "--db=" ^ db_fname ;
	      "--revision=" ^ old_id ;
	      "--revision=" ^ new_id ; "diff" ] in
  if Viz_misc.debug "exec"
  then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
  let error fmt =
    Printf.kprintf (fun s -> cb (`SUB_PROC_ERROR s)) fmt in
  try
    status#push "Running monotone ..." ;
    Subprocess.spawn_out
      ~encoding:`LOCALE ~cmd
      ~reap_callback:status#pop
      (fun ~exceptions ~stdout ~stderr status ->
	if status <> 0 then
	  if List.exists
	      (function
		| Glib.Convert.Error (Glib.Convert.ILLEGAL_SEQUENCE, _) -> true
		| _ -> false)
	      exceptions
	  then
	    error
	      begin
		let (is_utf8, _) = Glib.Convert.get_charset () in
		if is_utf8
		then format_of_string "Monotone output is not valid UTF-8"
		else format_of_string "Could not convert monotone output to UTF-8"
	      end
	  else
	    if stderr = ""
	    then
	      error "Monotone exited with status %d:\n%s" status
		(String.concat "\n" (List.map Printexc.to_string exceptions))
	    else
	      error "Monotone error:\n%s" stderr
	else
	  cb (`DIFF stdout))
  with Gspawn.Error (_, msg) ->
    Viz_types.errorf "Could not execute monotone:\n%s" msg







type t = {
    filename : string ;
    db       : Sqlite3.db ;
    pubkeys  : (string, Crypto.pub_rsa_key * int) Hashtbl.t ;
  }


let on_schema_error_retry f =
  try f () with Sqlite3.Error (Sqlite3.SCHEMA, _) -> f ()

let sqlite_try f db =
  try f db.db
  with Sqlite3.Error (_, msg) ->
    Viz_types.errorf "Error processing database %s:\n%s" db.filename msg



let kind = `FILE

let open_db fname =
  if not (Sys.file_exists fname)
  then Viz_types.errorf "No such file: %s" fname ;
  let db =
    try Sqlite3.open_db fname
    with Sqlite3.Error (_, msg) ->
      Viz_types.errorf "Could not open database %s:\n%s" fname msg in
  let pubkeys = Hashtbl.create 17 in
  let v = {
    filename = fname ;
    db       = db ;
    pubkeys  = pubkeys } in
  sqlite_try (fun db ->
    register_base64_functions db ;
    on_schema_error_retry (fun () ->
      fetch_pubkeys db pubkeys))
    v ;
  v

let close_db { db = db } =
  Sqlite3.close_db db

let get_filename d = d.filename

let fetch_branches db =
  sqlite_try fetch_branches db

let fetch_ancestry_graph db query =
  sqlite_try (fetch_agraph query) db

let fetch_revision d id =
    try
      let revision_set =
	sqlite_try (fun db ->
	  on_schema_error_retry (fun () ->
	    fetch_revision_set db id))
	  d in
      let (manifest_id, edges) = revision_set in
      { revision_id = id ;
	manifest_id = manifest_id ;
	revision_set =
	List.map
	  (fun e -> (e.Revision_types.old_revision, e.Revision_types.change_set) )
	  edges ;
	certs = [] }
    with Parsing.Parse_error ->
      Viz_types.errorf "Error while parsing revision set of %s" id

let fetch_certs_and_revision d id =
  { (fetch_revision d id)
    with certs =
      sqlite_try (fun db ->
        on_schema_error_retry (fun () ->
	  fetch_certs db d.pubkeys id)) d }

let fetch_cert_signer db id name =
  sqlite_try (fun _ -> fetch_one_cert_field db.db id name `SIGNER) db

let fetch_cert_value db id name =
  sqlite_try (fun _ -> fetch_one_cert_field db.db id name `VALUE) db

let get_key_rowid { pubkeys = pubkeys } id =
  let (_, rowid) = Hashtbl.find pubkeys id in
  rowid

let get_matching_cert db name p =
  List.rev
    (Sqlite3.fetch_f db.db
       (fun acc -> function
	 | [| id; v |] when p v -> (id, v) :: acc
	 | _ -> acc)
       []
       "SELECT id, unbase64(value) FROM revision_certs WHERE name = '%s'" name)

let get_matching_tags db p =
  get_matching_cert db "tag" p

let get_matching_dates db d_pref =
  get_matching_cert db "date"
    (string_is_prefix d_pref)

let run_monotone_diff db monotone_exe edge status cb =
  ignore
    (spawn_monotone_diff db.filename monotone_exe edge status cb)