Below is the file 'monotone.ml' from this revision. You can also download the file.

open Viz_types

type t = Automate.t

let make = Automate.make
let exit = Automate.exit

let report_error cb fmt =
  Printf.kprintf (fun s -> cb (`SUB_PROC_ERROR s)) fmt

let spawn_monotone mtn cmd input status cb =
  let mtn_exe, db_fname = Automate.get_info mtn in
  let cmd = mtn_exe :: "--db" :: db_fname :: cmd in
  try
    status#push "Running monotone ..." ;
    Subprocess.spawn
      ~encoding:`NONE ~cmd ~input
      ~reap_callback:status#pop
      (fun ~exceptions ~stdout ~stderr status ->
	if status = 0
	then
	  cb (`OUTPUT stdout)
	else if stderr = ""
	then
	  report_error cb
            "Monotone exited with status %d:\n%s"
            status
	    (String.concat "\n" (List.map Printexc.to_string exceptions))
	else
	   report_error cb
            "Monotone error:\n%s"
            stderr)
  with Gspawn.Error (_, msg) ->
    Viz_types.errorf "Could not execute monotone:\n%s" msg


let run_monotone_diff mtn status cb (old_id, new_id) =
  ignore (spawn_monotone
	    mtn
	    [ "--revision" ; old_id ;
	      "--revision" ; new_id ; "diff" ]
	    None status cb)



let decode_count_branches d =
  match Viz_misc.string_split '\n' d with
  | _ :: l ->
      let re = Str.regexp "\\([0-9]+\\) | \\(.*\\)" in
      List.map
        (fun r ->
          if Str.string_match re r 0
          then begin
            let b = Str.matched_group 2 r
            and n = Str.matched_group 1 r in
            b, int_of_string n
          end
          else failwith "Monotone.decode_count_branches: bad format")
        l
  | _ ->
      failwith "Monotone.decode_count_branches: bad format"

let fake_status () =
  object
    method push _ = ()
    method pop () = ()
  end

let wait_subproc mtn args =
  let output = ref None
  and exit_loop = ref false in
  let cb v = output := Some v ; exit_loop := true in
  ignore (spawn_monotone mtn args None (fake_status ()) cb) ;
  while not !exit_loop do
    ignore (Glib.Main.iteration true)
  done ;
  Viz_misc.some !output


let run_monotone_count_branches mtn =
  let counts =
    let args = [ "db" ; "execute" ;
                 "SELECT COUNT(*), value FROM revision_certs WHERE name = 'branch' GROUP BY value" ] in
    match wait_subproc mtn args with
    | `SUB_PROC_ERROR _ -> []
    | `OUTPUT d ->
        try decode_count_branches d
        with Failure _ -> [] in
  match counts with
  | [] -> fun b -> 0
  | _  ->
      let tbl = Viz_misc.hashtbl_of_list counts in
      fun b -> try Hashtbl.find tbl b with Not_found -> 0







let escape_selector s =
  let len = String.length s in
  let nb_escp = ref 0 in
  for i = 0 to len - 1 do
    let c = s.[i] in
    if c = '\\' || c = '/'
    then incr nb_escp
  done ;
  if !nb_escp = 0
  then s
  else begin
    let o = String.create (len + !nb_escp) in
    let j = ref 0 in
    for i = 0 to len - 1 do
      let c = s.[i] in
      if c = '\\' || c = '/'
      then (o.[!j] <- '\\' ; incr j) ;
      o.[!j] <- c ;
      incr j
    done ;
    assert (!j = len + !nb_escp) ;
    o
  end

let ( +> ) x f = f x

let decode_branches msg =
  Viz_misc.string_split '\n' msg

let branches mtn =
  Automate.submit_sync
    mtn
    [ "branches" ]
    +> decode_branches

let node_data_of_revision rev_id certs (m_id, edges) =
  { revision_id  = rev_id ;
    manifest_id  = m_id ;
    revision_set = List.map (fun e -> e.Revision.old_revision, e.Revision.change_set) edges ;
    certs        = certs ;
  }

let _get_revision mtn id certs =
  Automate.submit_sync
    mtn [ "get_revision" ; id ]
    +> Lexing.from_string
    +> Revision.revision_set
    +> node_data_of_revision id certs

let get_revision mtn id =
  _get_revision mtn id []




let get_elem st k =
  try
    Basic_io_lexer.string_of_elem
      (List.assoc k st)
  with Not_found -> "??"

let sig_verif = function
  | "ok"      -> SIG_OK
  | "bad"     -> SIG_BAD
  | "unknown" -> SIG_UNKNOWN
  | _ -> failwith "Monotone.sig_verif"

let cert_of_stanza id st =
  { c_id    	= id ;
    c_name  	= get_elem st "name" ;
    c_value 	= get_elem st "value" ;
    c_signer_id = get_elem st "key" ;
    c_signature = sig_verif (get_elem st "signature") ;
  }

let raw_certs mtn id =
  Automate.submit_sync
    mtn [ "certs" ; id ]
    +> Lexing.from_string
    +> Basic_io_lexer.parse

let certs mtn id =
  raw_certs mtn id
    +> List.map (cert_of_stanza id)

let get_certs_and_revision mtn id =
  certs mtn id
    +> _get_revision mtn id

let cert_value mtn id =
  let c = raw_certs mtn id in
  fun name ->
    Viz_misc.list_filter_map
      (fun st -> get_elem st "name" = name)
      (fun st -> get_elem st "value")
      c


let select mtn selector =
  Automate.submit_sync
    mtn [ "select" ; selector ]
    +> Viz_misc.string_split '\n'



let selectors_of_query q =
  match q.lim with
  | QUERY_NO_LIMIT ->
      List.map (fun b -> b, "b:" ^ escape_selector b) q.dom
  | QUERY_BETWEEN (d1, d2) ->
      let s_d =
	match escape_selector d1, escape_selector d2 with
	| "", "" -> []
	| d1, "" -> [ "l:" ^ d1 ]
	| "", d2 -> [ "e:" ^ d2 ]
	| d1, d2 -> [ "l:" ^ d1 ; "e:" ^ d2 ] in
      List.map
	(fun b ->
	  let s_b = "b:" ^ escape_selector b in
	  let s_t = String.concat "/" (s_b :: s_d) in
	  b, s_t)
	q.dom

let get_ids mtn query =
  List.fold_left
    (fun set (b, s) ->
      List.fold_left
	(fun set id ->
	  try
	    let bl = NodeMap.find id set in
	    bl := b :: !bl ;
	    set
	  with Not_found ->
	    NodeMap.add id (ref [ b ]) set)
	set
	(select mtn s))
    NodeMap.empty
    (selectors_of_query query)

let graph mtn =
  Automate.submit_sync
    mtn [ "graph" ]

let children mtn id f init =
  Automate.submit_sync mtn [ "children" ; id ]
    +> Viz_misc.string_split '\n'
    +> List.fold_left f init

let decode_graph f init data =
  let pos = ref 0 in
  let acc = ref init in
  begin
    try
      while true do
	let e = String.index_from data !pos '\n' in
	let nb = (e - !pos + 1) / 41 in (* len = 40 x k + k - 1 where k ∈ { 1, 2, 3 } *)
	let id = String.sub data !pos 40 in
	let p =
	  if nb <= 1 then
	    []
	  else if nb <= 2 then
	    [ String.sub data (!pos + 41) 40 ]
	  else
	    [ String.sub data (!pos + 41) 40 ; String.sub data (!pos + 82) 40 ] in
	acc := f !acc id p ;
	pos := e + 1
      done
    with Not_found -> ()
  end ;
  !acc

let ensure_node agraph id kind family =
  try
    let n = NodeMap.find id agraph.nodes in
    if n.kind < kind then n.kind <- kind ;
    n.family <- family @ n.family ;
    agraph
  with Not_found ->
    let n = { id = id ; kind = kind ; family = family } in
    { agraph with nodes = NodeMap.add id n agraph.nodes }

let edge_kind b_set i1 i2 =
  try
    let b1 = NodeMap.find i1 b_set in
    let b2 = NodeMap.find i2 b_set in
    if List.exists (fun b -> List.mem b !b1) !b2
    then SAME_BRANCH
    else BRANCHING
  with Not_found ->
    BRANCHING_NEIGH

let ensure_edge agraph b_set i1 i2 =
  let e = edge_kind b_set i1 i2 in
  { agraph with ancestry = EdgeMap.add (i1, i2) e agraph.ancestry }

let interesting_node id_set id =
  id_set = NodeMap.empty || NodeMap.mem id id_set

let only_one_child mtn id =
  children mtn id (fun n _ -> n + 1) 0 <= 1

let keep_neighbor_out mtn all_propagates p p_in_graph =
  all_propagates
    || List.length p_in_graph = List.length p
    || List.for_all (only_one_child mtn) p_in_graph

let add_node mtn query ids agraph id p =
  if interesting_node ids id
  then begin
    let agraph =
      ensure_node agraph id
	(if List.length p >= 2 then MERGE else REGULAR)
	(List.map (fun i -> i, PARENT) p) in
    let p =
      List.map (fun id_p -> id_p, interesting_node ids id_p) p in
    List.fold_left
      (fun agraph (id_p, is_reg) ->
	let agraph =
	  ensure_node agraph id_p
	    (if is_reg then REGULAR else NEIGHBOUR_IN)
	    [ id, CHILD ] in
	ensure_edge agraph ids id_p id)
      agraph p
  end
  else
    match List.filter (interesting_node ids) p with
    | [] ->
	agraph
    | p_in_graph when keep_neighbor_out mtn query.all_propagates p p_in_graph ->
	let agraph =
	  ensure_node agraph id
	    NEIGHBOUR_OUT
	    (List.map (fun i -> i, PARENT) p_in_graph) in
	List.fold_left
	  (fun agraph id_p ->
	    let agraph =
	      ensure_node agraph id_p
		REGULAR [ id, CHILD ] in
	    ensure_edge agraph ids id_p id)
	  agraph p_in_graph
    | _ ->
	agraph

let grab_tags mtn agraph =
  Automate.submit_sync mtn [ "tags" ]
    +> Lexing.from_string
    +> Basic_io_lexer.parse
    +> List.fold_left (fun agraph st ->
      try
	let n = NodeMap.find (get_elem st "revision") agraph.nodes in
	n.kind <- TAGGED (get_elem st "tag") ;
	agraph
      with Not_found -> agraph)
    agraph

let agraph mtn query =
  let ids = get_ids mtn query in
  graph mtn
    +> decode_graph (add_node mtn query ids) empty_agraph
    +> grab_tags mtn
    +> Components.reconnect (children mtn)

(* TODO:
   - distinguish between true neighbor nodes and nodes that are outside the date limit.
 *)


let join nb cb =
  let cnt = ref nb in
  let acc = ref [] in
  function
    | `OUTPUT data when !cnt = 1 ->
	let total = List.rev (data :: !acc) in
	cb (`OUTPUT total)
    | `OUTPUT data ->
	acc := data :: !acc ;
	decr cnt
    | `ERROR msg
    | `SYNTAX_ERROR msg ->
	cnt := 0 ;
	cb (`SUB_PROC_ERROR msg)

let decode cb = function
  | `SUB_PROC_ERROR _ as r ->
      cb r
  | `OUTPUT d ->
      let ids = List.flatten (List.map (Viz_misc.string_split '\n') d) in
      cb (`IDS ids)

let select_async mtn cb selectors =
  let nb_selectors =
    List.length selectors in
  let auto_cb = join nb_selectors (decode cb) in
  List.map
    (fun sel -> Automate.submit mtn [ "select" ; sel ] auto_cb)
    selectors