(* Copyright 2005-2008 Berke DURAK, INRIA Rocquencourt, Jaap BOENDER.

This file is part of Dose2.

Dose2 is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Dose2 is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

open Conduit
open Napkin
open Io
open Ocamlpkgsrc
module G = Generic_io
module DBI = Dosebase.In
;;

exception Conflicting_information of string

let sf = Printf.sprintf;;

type liquid = RPM | Debian | Pkgsrc

type glob = string

(*** ORDERED_LITERATE *)
module type ORDERED_LITERATE =
  sig
    type t
    val compare : t -> t -> int
    val scribe : 'a Conduit.conduit -> 'a -> t -> unit
    val io : t literate
  end
;;
(* ***)
(*** Version_order *)
module Version_order =
  struct
    type t = string
    let comparator = ref String.compare
    let compare u v = !comparator u v
    let set_comparator f = comparator := f
    let scribe cd oc u = cd.cd_print oc "%s" u
    let io = io_string
  end
;;
(* ***)
(*** Release *)
module Release_order =
  struct
    type t = string option
    let comparator = ref
			(fun a b ->
				match a, b with
				| None    , None     -> 0
				| None    , (Some _) -> (-1)
				| (Some _), None     -> 1
				| (Some x), (Some y) -> String.compare x y
			)
    let compare u v = !comparator u v
    let set_comparator f = comparator := f
    let scribe cd oc u = cd.cd_print oc "%s" (match u with None -> "" | Some x -> x)
    let io = io_option io_string
  end
;;
(*** STRING_ORDERED_LITERATE *)
module type STRING_ORDERED_LITERATE =
  sig
    type t = string
    val compare : t -> t -> int
    val scribe : 'a Conduit.conduit -> 'a -> t -> unit
    val io : string literate
  end
;;
(* ***)
(*** SET *)
module type SET =
  sig
    include Set.S
    val io : t literate
  end
;;
(* ***)
(*** ID *)
module type ID =
  sig
    type id
    val to_int : id -> int
		val from_int : int -> id
    val compare : id -> id -> int
    val succ : id -> id
    val scribe : 'a Conduit.conduit -> 'a -> id -> unit
    val zero : id
    val sweep : id -> (id -> unit) -> unit
    val io : id literate
  end
;;
(* ***)
(*** INDEXED *)
module type INDEXED =
  sig
    type id
    val compare_id : id -> id -> int
    val io_id : id literate
    val scribe_id : 'a Conduit.conduit -> 'a -> id -> unit
  end
;;
(* ***)
(*** INDEX *)
module type INDEX =
  sig
    type elt
    type id
    type t
    val create : unit -> t
    val register : t -> elt -> id
    val search : t -> elt -> id
    val find : t -> id -> elt
    val compare_id : id -> id -> int
    val scribe_id : 'a Conduit.conduit -> 'a -> id -> unit
    val io_id : id literate
    val iter : t -> (id -> elt -> unit) -> unit
    val set_watcher : t -> (id -> elt -> unit) -> unit
  end
;;
(* ***)
(*** type *)
module type DATA =
  sig
    type t
  end
;;
(* ***)
(*** LABELED_INDEX *)
module type LABELED_INDEX =
  sig
    type data
    type elt
    type id
    type t
    val create : unit -> t
    val register : t -> elt -> (unit -> data) -> id
    val search : t -> elt -> id
    val find : t -> id -> elt
    val data : t -> id -> data
    val compare_id : id -> id -> int
    val scribe_id : 'a Conduit.conduit -> 'a -> id -> unit
    val io_id : id literate
    val iter : t -> (id -> elt -> data -> unit) -> unit
    val set_watcher : t -> (id -> elt -> data -> unit) -> unit
  end
;;
(* ***)
(*** Labeled_index *)
module Labeled_index(D : DATA)(I : ORDERED_LITERATE) :
  LABELED_INDEX with type elt = I.t and type data = D.t
  =
  struct
    type elt = I.t
    type data = D.t
    type id = int

    type t = {
      idx_to_id   : (elt, id) Hashtbl.t;
      idx_from_id : (id, elt * data) Hashtbl.t;
      mutable idx_count : int;
      mutable idx_watcher : id -> elt -> data -> unit
    };;

    let create () = {
      idx_to_id   = Hashtbl.create 1009;
      idx_from_id = Hashtbl.create 1009;
      idx_count   = 0;
      idx_watcher = (fun _ _ _ -> ())
    };;

    let register idx e d =
      try
        Hashtbl.find idx.idx_to_id e
      with
      | Not_found ->
          let i = idx.idx_count in
          idx.idx_count <- 1 + i;
          Hashtbl.add idx.idx_to_id e i;
          let data = d () in
          Hashtbl.add idx.idx_from_id i (e, data);
          idx.idx_watcher i e data;
          i
    ;;

    let set_watcher idx f = idx.idx_watcher <- f;;

    let search idx e = Hashtbl.find idx.idx_to_id e;;

    let find idx id =
      let (e, _) = Hashtbl.find idx.idx_from_id id in e
    ;;

    let data idx id =
      let (_, d) = Hashtbl.find idx.idx_from_id id in d
    ;;

    let compare_id (id1 : id) (id2 : id) = compare id1 id2;;

    let scribe_id cd oc id = cd.cd_print oc "<%d>" id;;

    let io_id = io_int;;

    let iter idx f =
      for i = 0 to idx.idx_count - 1 do
        let (e, d) = Hashtbl.find idx.idx_from_id i in
        f i e d
      done
    ;;
  end
;;
(* ***)
(*** Index *)
module Index(I : ORDERED_LITERATE) :
  INDEX with type elt = I.t
  =
  struct
    module LI = Labeled_index(struct type t = unit end)(I)
    include LI
    let register idx e = register idx e ignore;;
    let iter idx f = LI.iter idx (fun id e _ -> f id e);;
    let set_watcher idx f = set_watcher idx (fun id e _ -> f id e);;
  end
;;
(* ***)
(*** DOUBLE_INDEX *)
module type DOUBLE_INDEX =
  sig
    type e1
    type e2
    type elt = e1 * e2
    type id
    type t
    val create : unit -> t
    val register : t -> elt -> id
		val replace : t -> elt -> unit
    val find : t -> id -> elt
    val search1 : t -> e1 -> id
    val search2 : t -> e2 -> id
    val compare_id : id -> id -> int
    val scribe_id : 'a Conduit.conduit -> 'a -> id -> unit
    val iter : t -> (id -> elt -> unit) -> unit
    val set_watcher : t -> (id -> elt -> unit) -> unit
  end
;;
(* ***)
(*** Double_index *)
module Double_index(ID : ID)(I1 : ORDERED_LITERATE)(I2 : ORDERED_LITERATE) : 
  DOUBLE_INDEX with type e1 = I1.t and type e2 = I2.t and type id = ID.id
  =
  struct
    type e1 = I1.t
    type e2 = I2.t
    type elt = e1 * e2

    type id = ID.id

    type t = {
      idx_i1_to_id : (I1.t, id) Hashtbl.t;
      idx_i2_to_id : (I2.t, id) Hashtbl.t;
      idx_from_id : (id, elt) Hashtbl.t;
      mutable idx_count : id;
      mutable idx_watcher : (id -> elt -> unit);
    };;

    let create () = {
      idx_i1_to_id = Hashtbl.create 1009;
      idx_i2_to_id = Hashtbl.create 1009;
      idx_from_id  = Hashtbl.create 1009;
      idx_count    = ID.zero;
      idx_watcher  = (fun _ _ -> ())
    };;

    let register idx (e1,e2) =
      try
        Hashtbl.find idx.idx_i1_to_id e1
      with
      | Not_found ->
          let id = idx.idx_count in
          idx.idx_count <- ID.succ id;
          Hashtbl.add idx.idx_i1_to_id e1 id;
          Hashtbl.add idx.idx_i2_to_id e2 id;
          Hashtbl.add idx.idx_from_id id (e1,e2);
          idx.idx_watcher id (e1,e2);
          id
    ;;

		let replace idx (e1,e2) =
			try
				let id = Hashtbl.find idx.idx_i1_to_id e1 in
				Hashtbl.replace idx.idx_i1_to_id e1 id;
				Hashtbl.replace idx.idx_i2_to_id e2 id;
				Hashtbl.replace idx.idx_from_id id (e1,e2);
				idx.idx_watcher id (e1,e2)
			with
			| Not_found -> ignore (register idx (e1, e2))
		;;

    let set_watcher idx f = idx.idx_watcher <- f;;

    let find idx id = Hashtbl.find idx.idx_from_id id;;

    let search1 idx e1 = Hashtbl.find idx.idx_i1_to_id e1;;

    let search2 idx e2 = Hashtbl.find idx.idx_i2_to_id e2;;

    let compare_id = ID.compare

    let scribe_id = ID.scribe

    let iter idx f =
      ID.sweep idx.idx_count
        begin fun id ->
          let e = Hashtbl.find idx.idx_from_id id in
          f id e;
        end
    ;;
  end
;;
(* ***)
(*** VERSION_POOL *)
module type VERSION_POOL =
  sig
    type version
    type handle
    type id
    type t
    val create : unit -> t
    val register : t -> version -> handle
    val search : t -> version -> handle
    val compare_versions : t -> handle -> handle -> int
    val find : t -> id -> handle
    val get_version : handle -> version
    val get_id : handle -> id
    val iter : t -> (handle -> unit) -> unit
    val scribe_id : 'a Conduit.conduit -> 'a -> id -> unit
    val io_id : id literate
  end
;;
(* ***)
(*** Version_pool *)
module Version_pool(V : ORDERED_LITERATE) :
  VERSION_POOL with type version = V.t
  =
  struct
    type version = V.t
    type id = int
    type handle = {
      mutable h_order : int;
      h_id : int;
      h_version : version
    }

    module VM = Map.Make(V)

    type t = {
      mutable vp_map      : handle VM.t;
      mutable vp_count    : int;
      mutable vp_disorder : bool;
      vp_from_id          : (id, handle) Hashtbl.t
    };;

    let create () = {
      vp_map         = VM.empty;
      vp_count       = 0; (* Number of distinct versions known to the system; also next ID *)
      vp_disorder    = false;
      vp_from_id     = Hashtbl.create 1009
    };;

    let get_version h = h.h_version;;
    let get_id h = h.h_id;;

    let find vp id = Hashtbl.find vp.vp_from_id id;;

    let reorder vp =
      let x = ref 0 in
      VM.iter
        begin fun _ h ->
          h.h_order <- !x;
          incr x
        end
        vp.vp_map;
      vp.vp_disorder <- false
    ;;

    let iter vp f =
      VM.iter
        begin fun _ h ->
          f h
        end
        vp.vp_map
    ;;

    let compare_versions vp h1 h2 =
      if vp.vp_disorder then reorder vp;
      compare h1.h_order h2.h_order
    ;;

    let register vp v =
			try
      	VM.find v vp.vp_map 
      with
      | Not_found ->
          vp.vp_disorder <- true;
          let id = vp.vp_count in
          vp.vp_count <- 1 + id;
          let h =
            { h_order   = 0;
              h_id      = id;
              h_version = v }
          in
          vp.vp_map <- VM.add v h vp.vp_map;
          Hashtbl.add vp.vp_from_id id h;
          h
    ;;

    let search vp v = VM.find v vp.vp_map;;

    let scribe_id cd oc id = cd.cd_print oc "<%d>" id;;

    let io_id = io_int;;
  end
;;
(* ***)
(*** Perishable *)
module Perishable =
  struct
    type 'a t = {
      p_time : int ref;
      p_contents : 'a option;
      mutable p_build_date : int
    }

    let create time = {
      p_time = time;
      p_contents = None;
      p_build_date = min_int
    };;
  end
;;
(* ***)
(*** CHRONOLOGICAL_PARAMETER *)
module type CHRONOLOGICAL_PARAMETER =
  sig
    val n : int
  end
;;
(* ***)
(*** Set *)
module Set(O : ORDERED_LITERATE) : SET with type elt = O.t =
  struct
    module S = Set.Make(O)

    let io = io_collection
      begin
        O.io,
        (fun ps f -> S.iter f ps),
        begin fun () ->
          let ps = ref S.empty in
          (fun i -> ps := S.add i !ps),
          (fun () -> !ps)
        end
      end

    include S
  end
;;
(* ***)
(*** CHRONOLOGICAL_MAP *)
module type CHRONOLOGICAL_MAP =
  sig
    type t
    type set
    type elt
    type day = int
    val io : t Io.literate
    val create : unit -> t
    val iter : (day -> set -> unit) -> t -> unit
    val range : t -> day * day
    val get : t -> day -> set
    val add : t -> day -> day -> set -> unit
  end
;;
(* ***)
(*** Chronological_Map *)
module Chronological_Map(IS : SET)(P : CHRONOLOGICAL_PARAMETER) :
  CHRONOLOGICAL_MAP with type elt = IS.elt and type set = IS.t
  =
  struct
    open P;;

    type elt = IS.elt
    type set = IS.t
    type day = int
    ;;

    module WM = Map.Make(struct type t = int let compare = compare end);;
    type week = {
      mutable wk_base : IS.t;
      wk_deltas : IS.t option array;
    }
    type t = {
      mutable cm_weeks : week WM.t; (** Maps Julian week number to [week]. *)
    }
    let io_deltas = io_array (io_option IS.io);;

    let io_wm xio = io_collection
      begin
        io_pair io_int xio,
        (fun wm f -> WM.iter (fun k v -> f (k,v)) wm),
        begin fun () ->
          let wm = ref WM.empty in
          (fun (i,x) -> wm := WM.add i x !wm),
          (fun () -> !wm)
        end
      end
    ;;

    let io_week = 
      io_record
      [
        "base",
        (fun x i -> { x with wk_base = read IS.io i }),
        (fun x -> write IS.io x.wk_base);
        "deltas",
        (fun x i -> { x with wk_deltas = read io_deltas i }),
        (fun x -> write io_deltas x.wk_deltas)
      ]
      { wk_base = IS.empty;
        wk_deltas = [||] }
    ;;
    let io =
      io_convert
        (fun wks -> { cm_weeks = wks })
        (fun cm -> cm.cm_weeks)
        (io_wm io_week)
    ;;
    (*** create *)
    (** Creates a new chronological map. *)
    let create () = { cm_weeks = WM.empty };;
    (* ***)
    let week_of_julian j = j / n;;
    let next_week_of_julian j = (week_of_julian j) + 1;;
    let day_of_julian j =
      if j < 0 then
        n - ((- j) mod n)
      else
        j mod n
    ;;
    let julian_of_week w = w * n;;
    (*** iter *)
    let iter f cm =
      WM.iter
        begin fun w wk -> 
          let jw = julian_of_week w in
          let current = ref wk.wk_base in
          for i = 0 to n - 1 do
            let j = jw + i in
            current := (match wk.wk_deltas.(i) with
							None -> IS.empty
						| Some x ->	IS.union !current x);
            f j !current
          done
        end
        cm.cm_weeks
    ;;
    (* ***)
    (*** get_week *)
    let get_week cm w =
      try
        WM.find w cm.cm_weeks 
      with
      | Not_found ->
          let wk =
            { wk_base = IS.empty;
              wk_deltas = Array.make n None }
          in
          cm.cm_weeks <- WM.add w wk cm.cm_weeks;
          wk
    ;;
    (* ***)
    (*** add_to_week_base *)
    let add_to_week_base cm w ps =
      let wk = get_week cm w in
      wk.wk_base <- IS.union ps wk.wk_base
    ;;
    (* ***)
		(*** unempty_delta *)
		let unempty_delta cm w d =
			let wk = get_week cm w in
			wk.wk_deltas.(d) <- (match wk.wk_deltas.(d) with
			| None -> Some IS.empty
			| Some x -> Some x)
		;;
		(* ***)
    (*** add_to_delta *)
    let add_to_delta wk d ps =
      wk.wk_deltas.(d) <- (match wk.wk_deltas.(d) with
				None -> Some ps
			| Some x -> Some (IS.union ps x))
    ;;
    (* ***)
    (*** range *)
    let range cm =
      let w0 = ref max_int
      and w1 = ref min_int
      in
      (* We should have MAP.min_key, MAP.max_key *)
      WM.iter
        begin fun w _ ->
         	w0 := min w !w0;
         	w1 := max w !w1
        end
        cm.cm_weeks;
      let w0 = !w0
      and w1 = !w1
      in
      let wk0 = get_week cm w0
      and wk1 = get_week cm w1
      in
      let j0 = julian_of_week w0
      and j1 = julian_of_week w1
      in
      let j0 =
        if IS.is_empty wk0.wk_base then
          begin
            let rec loop d =
              assert (d < n);
							match wk0.wk_deltas.(d) with
								None -> loop (d + 1)
							| Some _ -> j0 + d
            in
            loop 0
          end
        else
          j0
      and j1 =
        if IS.is_empty wk1.wk_base then
          begin
            let rec loop d =
              assert (d >= 0);
							match wk1.wk_deltas.(d) with
								None -> loop (d - 1)
              | Some _ -> j1 + d
            in
            loop (n - 1)
          end
        else
          j1 + n - 1
      in
      (j0,j1)
    ;;
    (* ***)
    (*** get *)
    let get cm j =
      let w = week_of_julian j in
      let wk = get_week cm w in
      let d = day_of_julian j in
				match wk.wk_deltas.(d) with
					None -> IS.empty
        | Some x -> IS.union wk.wk_base x
    ;;
    (* ***)
    (*** add *)
    let add cm j0 j1 p =
      if j0 > j1 then
        (* Empty range *)
        ()
      else
        begin
          let w0 = week_of_julian j0
          and w1 = week_of_julian j1
          in
          let d0 = day_of_julian j0
          and d1 = day_of_julian j1
          in
          let wk0 = get_week cm w0 in
          if w0 = w1 then
            (* Single week *)
            if d0 = 0 && d1 = n - 1 then
						begin
              (* Full week *)
              add_to_week_base cm w0 p;
							for d = d0 to d1 do
								unempty_delta cm w0 d
							done
						end
            else
              (* Less than a week *)
              for d = d0 to d1 do
                add_to_delta wk0 d p
              done
          else
            begin
              (* Multi-weeks *)
              (* Suffix of first week *)
              if d0 = 0 then
							begin
                (* Present all this week: add to the week base. *)
                add_to_week_base cm w0 p;
								for d = 0 to 6 do
									unempty_delta cm w0 d
								done
							end
              else
                (* Starts in the middle of the first week.  Add to deltas. *)
                for d = d0 to n - 1 do
                  (* Add to the deltas *)
                  add_to_delta wk0 d p
                done;

              (* Add to the base of intermediary weeks where it's present all the week *)
              for w = w0 + 1 to w1 - 1 do
                add_to_week_base cm w p;
								for d = 0 to 6 do
									unempty_delta cm w d
								done
              done;

              (* Do last week *)
              if d1 = n - 1 then
							begin
                (* Whole week *)
                add_to_week_base cm w1 p;
								for d = 0 to d1 do
									unempty_delta cm w1 d
								done
							end
              else
                (* Ends in the middle of last week. *)
                begin
                  let wk1 = get_week cm w1 in
                  for d = 0 to d1 do
                    add_to_delta wk1 d p
                  done
                end
            end
        end
    (* ***)
  end
;;
(* ***)
(*** V *)
module V = Version_order;;
(* ***)
(*** Version_index *)
module Version_index = Version_pool(V);;
(* ***)
(*** R *)
module R = Release_order;;
(* ***)
(*** Release_index *)
module Release_index = Version_pool(R);;
(* ***)
(*** archive_name, ... *)
type archive_name         = string;;
type architecture_name    = string;;
type unit_name            = string;;
type version_name         = Version_index.version;;
type source_name          = unit_name * version_name
type source_version_name  = version_name;;
type version_number       = Version_index.handle;;
type release_number       = Release_index.handle;;
type version_id           = Version_index.id;;
type release_id           = Release_index.id;;
(* ***)
(*** Set_of_index(I *)
module Set_of_index(I : INDEXED) :
  SET with type elt = I.id
  =
  struct
    module S =
      Set(struct
        type t = I.id
        let compare = I.compare_id
        let io = I.io_id
        let scribe = I.scribe_id
      end)
    include S
  end
;;
(* ***)
(*** Archive_name *)
module Archive_name =
  struct
    type t = archive_name
    let compare = compare
    let scribe = scribe_string
    let io = io_string
  end
;;
(* ***)
(*** Architecture_name *)
module Architecture_name =
  struct
    type t = architecture_name
    let compare = compare
    let scribe = scribe_string
    let io = io_string
  end
;;
(* ***)
(*** Architecture_index *)
module Architecture_index = Index(Architecture_name);;
(* ***)
(*** Unit_name *)
module Unit_name =
  struct
    type t = unit_name
    let compare = compare
    let scribe = scribe_string
    let io = io_string
  end
;;
(* ***)
(*** Package_ID *)
module Package_ID :
  ID
  =
  struct
    type id = int;;
    let to_int id = id;;
		let from_int id = id;;
    let compare (id1 : id) (id2 : id) = compare id1 id2;;
    let succ id = id + 1;;
    let zero = 0;;
    let scribe cd oc id = cd.cd_print oc "<%d>" id;;
    let io = io_int;;
    let sweep id f = 
      for i = 0 to id - 1 do
        f i
      done
    ;;
  end
;;
(* ***)
(*** Package_set *)
module Package_set =
  Set(struct
    include Package_ID
    type t = Package_ID.id
  end)
;;
(* ***)
type package_id = Package_ID.id;;
type package_set = Package_set.t;;

(*** Unit_data *)
module Unit_data =
  struct
    type t = {
      mutable ud_packages : package_set; (* Package who have exactly this unit *)
      mutable ud_providers : (package_id, version_number * release_number, glob) versioned list; (* Packages who potentially provide this unit *)
     }
  end
;;
(* ***)
(*** Unit_index *)
module Unit_index = Labeled_index(Unit_data)(Unit_name);;
(* ***)
(*** Unit_set *)
module Unit_set = Set_of_index(Unit_index);;
(* ***)
type unit_id = Unit_index.id;;
type unit_set = Unit_set.t;;
(*** Source_name *)
module Source_name =
  struct
    type t = unit_name * version_name
    let compare = compare
    let scribe cd oc (u,v) = cd.cd_print oc "%s`%s" u v
    let io = io_pair io_string io_string
  end
;;
(* ***)
(*** Source_index  *)
module Source_index  = Index(Source_name);;
(* ***)
(*** Source_set *)
module Source_set = Set_of_index(Source_index);;
(* ***)
type source_id = Source_index.id;;
type source_set = Source_set.t;;
type architecture_id      = Architecture_index.id;;
type package_name         = unit_id * version_id * release_id * architecture_id;;
(*** Chronology *)
module Chronology =
  Chronological_Map(Package_set)(struct let n = 7 end);;
(* ***)

(* ***)
(*** Archives *)
type archive = {
  ar_key : archive_name;
  ar_contents : Chronology.t;
}

module Archive_index =
  Labeled_index
    (struct type t = archive end)
    (Archive_name)

module Archive_set = Set_of_index(Archive_index);;

type archive_id = Archive_index.id

type archive_set = Archive_set.t
(* ***)
(*** package_extra *)
type package_extra =
  {
    px_conflict_cache : package_set Perishable.t; (** Packages that conflict with this one *)
  }
;;
(* ***)
(*** package *)
type package =
  (package_extra,
   unit_id,
   version_number * release_number,
	 glob,
   architecture_id,
   source_id)
  Napkin.package
;;
(* ***)
(*** Package_index *)
module Package_index =
  Double_index
    (Package_ID)
    (struct
      type t = package_name
      let compare = compare
      let scribe cd oc _p = cd.cd_print oc "<?>"
      let io = io_quadruple Unit_index.io_id Version_index.io_id Release_index.io_id Architecture_index.io_id
     end)
    (struct
      type t = package
      let compare = compare
      let scribe cd oc _ = cd.cd_print oc "<?>"
      let io = io_not_implemented
    end)
;;
(* ***)
(*** db *)
type db = {
	db_liquid              : liquid option ref;
  (* Main indexes *)
  db_unit_index          : Unit_index.t;
  db_package_index       : Package_index.t;
  db_architecture_index  : Architecture_index.t;
  db_source_index        : Source_index.t;
  db_version_index       : Version_index.t;
	db_release_index       : Release_index.t;
  db_archive_index       : Archive_index.t;
  (* Universes *)
  mutable db_packages    : package_set;
  mutable db_units       : unit_set;
  mutable db_sources     : source_set;
  mutable db_archives    : archive_set;
  (* Timestamp for perishable goods *)
  db_time                : int ref;
};;
(* ***)

let get_liquid db = !(db.db_liquid);;
let get_package_index db = db.db_package_index;;
let get_unit_index db = db.db_unit_index;;
let get_architecture_index db = db.db_architecture_index;;
let get_version_index db = db.db_version_index;;
let get_release_index db = db.db_release_index;;
let get_archive_index db = db.db_archive_index;;
let get_source_index db = db.db_source_index;;

let set_liquid db l = db.db_liquid := Some l;;

(*** split_version *)
let split_version (x: string): string * string option =
begin
	try let hyphen_index = String.rindex x '-' in
		let vstr = String.sub x 0 hyphen_index
		and rstr = String.sub x (hyphen_index+1) ((String.length x)-hyphen_index-1) in
			(vstr, if rstr = "" then None else Some rstr)
	with Not_found -> try
		Scanf.sscanf x "%s@nb%s" (fun v r -> (v, if r = "" then None else Some r))
	with _ -> (x, None)
end;;
(* ***)
(*** register_version *)
let register_version db x =
	let (v, r) = split_version x in
		(Release_index.register db.db_release_index r,
		 Version_index.register db.db_version_index v)
;;
(* ***)
(*** register_unit *)
let register_unit db u =
  Unit_index.register
    db.db_unit_index
    u
    (fun () ->
      { Unit_data.ud_packages  = Package_set.empty;
        Unit_data.ud_providers = [] })
;;
(* ***)
(*** archive_index_watcher *)
let archive_index_watcher db u_id _ _ = db.db_archives <- Archive_set.add u_id db.db_archives;;
(* ***)
(*** unit_index_watcher *)
let unit_index_watcher db u_id _ _ = db.db_units <- Unit_set.add u_id db.db_units;;
(* ***)
(*** source_index_watcher *)
let source_index_watcher db s_id (u,v) =
  ignore (register_unit db u);
  ignore (register_version db v);
  db.db_sources <- Source_set.add s_id db.db_sources;
;;
(* ***)
(*** package_index_watcher *)
let package_index_watcher db p_id _ = db.db_packages <- Package_set.add p_id db.db_packages;;
(* ***)
(*** create_database *)
let create_database () =
  let db =
    { db_liquid              = ref None;
      db_unit_index          = Unit_index.create ();
      db_package_index       = Package_index.create ();
      db_architecture_index  = Architecture_index.create ();
      db_source_index        = Source_index.create ();
      db_version_index       = Version_index.create ();
			db_release_index       = Release_index.create ();
      db_archive_index       = Archive_index.create ();
      db_packages            = Package_set.empty;
      db_sources             = Source_set.empty;
      db_units               = Unit_set.empty;
      db_archives            = Archive_set.empty;
      db_time                = ref 0 }
  in
  Unit_index.set_watcher db.db_unit_index (unit_index_watcher db);
  Source_index.set_watcher db.db_source_index (source_index_watcher db);
  Package_index.set_watcher db.db_package_index (package_index_watcher db);
  Archive_index.set_watcher db.db_archive_index (archive_index_watcher db);
  db
;;
(* ***)
(*** archive_range *)
let archive_range db ar = Chronology.range ar.ar_contents;;
(* ***)
(*** get_archive *)
let get_archive db archive_id = Archive_index.data db.db_archive_index archive_id;;
(* ***)
(*** get_archive_contents *)
let get_archive_contents ar day = Chronology.get ar.ar_contents day;;
(* ***)

(*** iterate_over_archive *)
let iterate_over_archive f ar = Chronology.iter f ar.ar_contents;;
(* ***)
(*** add_archive *)
let add_archive db archive_name =
  Archive_index.register
    db.db_archive_index
    archive_name
    begin fun () ->
      { ar_key = archive_name;
        ar_contents = Chronology.create ();
			}
    end
(* ***)
(*** add_packages_to_archive *)
let add_packages_to_archive db ar set lf =
  Lifetime.iterate_over_intervals
    begin fun (j0,j1) ->
      Chronology.add ar.ar_contents j0 j1 set
    end
    lf
;;
(* ***)
(*** name_of_package *)
let name_of_package db p =
  (p.pk_unit, Version_index.get_id (fst p.pk_version), Release_index.get_id (snd p.pk_version), p.pk_architecture)
;;
(* ***)
(*** add_package *)
let add_package db (nk : Napkin.default_package) =
  let px = {
    px_conflict_cache = Perishable.create db.db_time;
  }
  in
  let p =
    Napkin.map
      ~extra:(fun _ -> px)
      ~unit:(register_unit db)
      ~version:(fun x ->
					let (v, r) = split_version x in
						Version_index.register db.db_version_index v,
						Release_index.register db.db_release_index r)
			~glob:(fun g -> g)
      ~architecture:(Architecture_index.register db.db_architecture_index)
      ~source:(Source_index.register db.db_source_index)
      nk
  in
  let package_id      =
    Package_index.register
      db.db_package_index
      (name_of_package db p, p)
  in
  let ud = Unit_index.data db.db_unit_index p.pk_unit in
  ud.Unit_data.ud_packages <- Package_set.add package_id ud.Unit_data.ud_packages;
  List.iter
    begin fun prv ->
			match prv with
			| Unit_version (unit_id', sel) -> let ud' = Unit_index.data db.db_unit_index unit_id' in
      	ud'.Unit_data.ud_providers <- Unit_version (package_id, sel) :: (ud'.Unit_data.ud_providers)
			| Glob_pattern p -> raise (Invalid_argument "Glob_pattern in providers, bailing out")
    end
		(if !(db.db_liquid) = Some RPM then
			p.pk_provides
		else
    	((Unit_version (p.pk_unit, Sel_ANY)) :: p.pk_provides));
  package_id
;;
(* ***)
(*** replace_package *)
let replace_package db p (* (nk : Napkin.default_package) *) =
  let px = {
    px_conflict_cache = Perishable.create db.db_time;
  }
  in
  Package_index.replace
     db.db_package_index
    (name_of_package db p, p);
	let package_id = Package_index.search1 db.db_package_index (name_of_package db p) in
  List.iter
    begin fun prv ->
			match prv with
			| Unit_version (unit_id', sel) -> let ud' = Unit_index.data db.db_unit_index unit_id' in
      	ud'.Unit_data.ud_providers <- Unit_version (package_id, sel) :: (ud'.Unit_data.ud_providers)
			| Glob_pattern p -> raise (Invalid_argument "Glob_pattern in providers, bailing out")
    end
		(if !(db.db_liquid) = Some RPM then
			p.pk_provides
		else
    	((Unit_version (p.pk_unit, Sel_ANY)) :: p.pk_provides))
;;
(* ***)
(*** Functions *)
module Functions =
  struct
    (*** scribe_version_from_number *)
    let scribe_version_from_number _db cd oc (v_n, r_n) =
      let version_name = Version_index.get_version v_n 
			and release_name = Release_index.get_version r_n in
			match release_name with
				None -> cd.cd_print oc "'%s" version_name
			| Some r -> cd.cd_print oc "'%s-%s" version_name r
    ;;
    (* ***)
    (*** scribe_archive_from_id *)
    let scribe_archive_from_id db cd oc a_id =
      let archive_name = Archive_index.find db.db_archive_index a_id in
      cd.cd_print oc "%%%s" archive_name
    ;;
    (* ***)
    (*** scribe_unit_from_id *)
    let scribe_unit_from_id db cd oc u_id =
      let unit_name = Unit_index.find db.db_unit_index u_id in
      cd.cd_print oc "%s" unit_name
    ;;
    (* ***)
    (*** scribe_source_from_id *)
    let scribe_source_from_id db cd oc s_id =
      let (unit_name, version_name) = Source_index.find db.db_source_index s_id in
      cd.cd_print oc "%s`%s" unit_name version_name
    ;;
    (* ***)
    (*** scribe_package *)
    let scribe_package db cd oc ?default_architecture p =
			let scribe_rel r = match r with None -> "" | Some x -> ("-" ^ x) in
      let unit_name = Unit_index.find db.db_unit_index p.pk_unit
      and architecture = Architecture_index.find db.db_architecture_index p.pk_architecture
      and version = Version_index.get_version (fst p.pk_version) 
			and release = Release_index.get_version (snd p.pk_version) in
      match default_architecture with
      | None -> cd.cd_print oc "%s'%s%s@%s" unit_name version (scribe_rel release) architecture
      | Some a_id ->
          if a_id = p.pk_architecture then
            cd.cd_print oc "%s'%s%s" unit_name version (scribe_rel release)
          else
            cd.cd_print oc "%s'%s%s@%s" unit_name version (scribe_rel release) architecture
    ;;
    (* ***)
    (*** get_package_from_id *)
    let get_package_from_id db p_id =
      let (_,p) = Package_index.find db.db_package_index p_id in
      p
    ;;
    (* ***)
    (*** scribe_package_from_id *)
    let scribe_package_from_id db cd oc ?default_architecture p_id =
      scribe_package db cd oc ?default_architecture (get_package_from_id db p_id);;
    (* ***)
    (*** unit_id_to_package_set *)
    let unit_id_to_package_set db unit_id =
      let ud = Unit_index.data db.db_unit_index unit_id in
      ud.Unit_data.ud_packages
    ;;
    (* ***)
    (*** unit_id_to_providers *)
    let unit_id_to_providers db unit_id =
      let ud = Unit_index.data db.db_unit_index unit_id in
      ud.Unit_data.ud_providers
    ;;
    (* ***)
    module PS = Package_set;;
    (*** packages, units, sources *)
    let packages db = db.db_packages;;
    let units db = db.db_units;;
    let sources db = db.db_sources;;
    let archives db = db.db_archives;;
    (* ***)
    (*** select *)
    let select db depspec =
		begin
			let vcmp = Version_index.compare_versions db.db_version_index
			and rcmp = Release_index.compare_versions db.db_release_index in
			let rpmcmp v1 r1 v2 r2 =
			begin
				if vcmp v1 v2 < 0 then -1
				else if vcmp v1 v2 > 0 then 1
				else (* vcmp v1 v2 = 0 *)
					let rs1 = Release_index.get_version r1
					and rs2 = Release_index.get_version r2 in
					begin
						if (rs1 = None) || (rs2 = None) then 0
						else if rcmp r1 r2 < 0 then -1
						else if rcmp r1 r2 > 0 then 1
						else (* rcmp r1 r2 = 0 *) 0
					end
			end in
			let rpmcheck asel gsel =
			begin
				match asel with
				| Sel_ANY -> true
				| Sel_LT (av, ar) -> 
					begin
						match gsel with
						| Sel_ANY | Sel_LT _ | Sel_LEQ _ -> true
						| Sel_EQ (gv, gr) -> rpmcmp av ar gv gr > 0
						| Sel_GEQ (gv, gr) -> rpmcmp av ar gv gr > 0
						| Sel_GT (gv, gr) -> rpmcmp av ar gv gr > 0
					end
				| Sel_LEQ (av, ar) ->
					begin
						match gsel with
						| Sel_ANY | Sel_LT _ | Sel_LEQ _ -> true
						| Sel_EQ (gv, gr) -> rpmcmp av ar gv gr >= 0
						| Sel_GEQ (gv, gr) -> rpmcmp av ar gv gr >= 0
						| Sel_GT (gv, gr) -> rpmcmp av ar gv gr > 0
					end
				| Sel_EQ (av, ar) ->
					begin
						match gsel with
						| Sel_ANY -> true
						| Sel_LT (gv, gr) -> rpmcmp av ar gv gr < 0
						| Sel_LEQ (gv, gr) -> rpmcmp av ar gv gr <= 0
						| Sel_EQ (gv, gr) -> rpmcmp av ar gv gr = 0
						| Sel_GEQ (gv, gr) -> rpmcmp av ar gv gr >= 0
						| Sel_GT (gv, gr) -> rpmcmp av ar gv gr > 0
					end	
				| Sel_GEQ (av, ar) ->
					begin
						match gsel with
						| Sel_ANY | Sel_GEQ _ | Sel_GT _ -> true
						| Sel_LT (gv, gr) -> rpmcmp av ar gv gr < 0
						| Sel_LEQ (gv, gr) -> rpmcmp av ar gv gr <= 0
						| Sel_EQ (gv, gr) -> rpmcmp av ar gv gr <= 0
					end
				| Sel_GT (av, ar) ->
					begin
						match gsel with
						| Sel_ANY | Sel_GEQ _ | Sel_GT _ -> true
						| Sel_LT (gv, gr) -> rpmcmp av ar gv gr < 0
						| Sel_LEQ (gv, gr) -> rpmcmp av ar gv gr < 0
						| Sel_EQ (gv, gr) -> rpmcmp av ar gv gr < 0
					end
			end in
			let debcmp v1 r1 v2 r2 = 
			begin
				if vcmp v1 v2 < 0 then -1
				else if vcmp v1 v2 > 0 then 1
				else (* vcmp v1 v2 = 0 *)
					let rs1 = Release_index.get_version r1
					and rs2 = Release_index.get_version r2 in
					begin
						if (rs1 = None) && (rs2 = None) then 0
						else if rs1 = None then -1
						else if rs2 = None then 1
						else rcmp r1 r2
					end
			end in
			let debcheck sel (gv, gr) =
			begin
				match sel with
				| Sel_ANY	-> true
				| Sel_LT  (av, ar) -> debcmp gv gr av ar < 0 
				| Sel_LEQ (av, ar) -> debcmp gv gr av ar <= 0 
				| Sel_EQ  (av, ar) -> debcmp gv gr av ar = 0 
				| Sel_GEQ (av, ar) -> debcmp gv gr av ar >= 0
				| Sel_GT  (av, ar) -> debcmp gv gr av ar > 0
			end in
			let pscheck sel (gv, gr) =
			begin
				match sel with
				| Sel_ANY -> true
				| Sel_LT (av, ar) -> debcmp gv gr av ar < 0 
				| Sel_LEQ (av, ar) -> debcmp gv gr av ar <= 0 
				| Sel_EQ  (av, ar) -> debcmp gv gr av ar = 0 
				| Sel_GEQ (av, ar) -> debcmp gv gr av ar >= 0
				| Sel_GT  (av, ar) -> debcmp gv gr av ar > 0
			end in
			if !(db.db_liquid) = (Some RPM) then
			begin
				match depspec with
				| Unit_version (unit_id, selector) -> 
					let udata = Unit_index.data db.db_unit_index unit_id in
					let pkgs = ref PS.empty in
					List.iter
						(fun d -> match d with
							| Unit_version (p, ps) -> if rpmcheck selector ps then
								pkgs := PS.add p !pkgs
							| Glob_pattern _ -> raise (Failure "RPM does not support glob patterns") 
						)
						udata.Unit_data.ud_providers;
						!pkgs
				| Glob_pattern _ -> raise (Failure "RPM does not support glob patterns")
			end
			else if !(db.db_liquid) = (Some Pkgsrc) then
			begin
				match depspec with
				| Unit_version (unit_id, selector) ->
					let udata = Unit_index.data db.db_unit_index unit_id in
					let pkgs = ref PS.empty in
					PS.iter
						(fun p_id -> 
							let p = get_package_from_id db p_id in
							if pscheck selector p.pk_version then
								pkgs := PS.add p_id !pkgs
							)
						udata.Unit_data.ud_packages;
						!pkgs
				| Glob_pattern g ->
					let vos u v rq =
						match rq with
						| None -> Printf.sprintf "%s-%s" u v
						| Some r -> Printf.sprintf "%s-%snb%s" u v r in
					let pkgs = ref PS.empty in
					PS.iter
						(fun p_id ->
							let p = get_package_from_id db p_id in
							let un = Unit_index.find db.db_unit_index p.pk_unit in
							let vn = Version_index.get_version (fst p.pk_version) in
							let rn = Release_index.get_version (snd p.pk_version) in
							if fnmatch g (vos un vn rn) [FNM_PERIOD] then
								pkgs := PS.add p_id !pkgs
						)
						db.db_packages;
						!pkgs
			end
			else
			begin
				match depspec with
				| Unit_version (unit_id, selector) -> 
					let udata = Unit_index.data db.db_unit_index unit_id in
					begin
					match selector with
						|	Sel_ANY ->
							let pkgs = ref PS.empty in
							List.iter
								(fun d -> match d with
									| Unit_version (p, _) -> pkgs := PS.add p !pkgs
									| Glob_pattern _ -> raise (Failure "Only Pkgsrc supports glob patterns"))
							udata.Unit_data.ud_providers;
							!pkgs
						| _ -> 
							let pkgs = ref PS.empty in
							PS.iter
								(fun p_id -> 
									let p = get_package_from_id db p_id in
									if debcheck selector p.pk_version then
									pkgs := PS.add p_id !pkgs)
							udata.Unit_data.ud_packages;
							!pkgs
					end
				| Glob_pattern _ -> raise (Failure "Only Pkgsrc supports glob patterns")
			end
		end;;
    (* ***)
    (*** conflicts *)
    let conflicts db ps =
      (* val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a *)
      PS.fold
        begin fun p_id set ->
          let p = get_package_from_id db p_id in
          List.fold_left
            begin fun set versioned ->
              PS.union set (select db versioned)
            end
            set
            (p.pk_conflicts @ p.pk_breaks)
        end
        ps
        PS.empty
    ;;
    (* ***)
    (*** dependency_closure *)
    let dependency_closure db ?(relations=[`Pre;`Dep]) s =
      let queue = ref s in
      let visited = ref PS.empty in
      while not (PS.is_empty !queue) do
        let p_id = PS.choose !queue in
        queue := PS.remove p_id !queue;
        visited := PS.add p_id !visited;
        let p = get_package_from_id db p_id in
        let process =
          List.iter
            begin fun disjunction ->
              List.iter
                begin fun versioned ->
                  let ps = select db versioned in
                  PS.iter (fun p_id' ->
                    if not (PS.mem p_id' !visited) then
                      queue := PS.add p_id' !queue) ps
                end
                disjunction
            end
        in
        List.iter
          begin function
          | `Pre -> process p.pk_pre_depends
          | `Dep -> process p.pk_depends;
          end
          relations
      done;
      !visited
    ;;
    (* ***)
(* ***) 
let dependency_path ?(conjunctive=false) db ps p1 p2 =
let visited = ref Package_set.empty in
let rec visit todo preds =
begin
	if Package_set.is_empty todo then None
	else if Package_set.mem p2 todo then Some (List.rev (p2::preds))
	else
	begin
		Package_set.fold (fun p acc ->
			if Package_set.mem p !visited then acc
			else
      begin
        visited := Package_set.add p !visited;
        let pkg = get_package_from_id db p in
			  match acc with
			  | None ->
				  begin
					  let deps = List.fold_left (fun acc d ->
						  List.fold_left (fun acc' a ->
							  let pkgs = Package_set.inter (select db a) ps in
							  if conjunctive && Package_set.cardinal pkgs > 1
							  then acc'
							  else Package_set.union acc' pkgs
						  ) acc d
					  ) Package_set.empty (pkg.pk_depends @ pkg.pk_pre_depends) in
					  visit deps (p::preds)
				  end
			  | Some a -> Some a
      end
		) todo None
	end
end in
begin
	visit (Package_set.singleton p1) []
end;;

end;;
(*** self_test *)
let self_test db =
  let cd = stdoutcd in
  let oc = cd.cd_out_channel in
  let vp = db.db_version_index in
  Printf.printf "Versions:\n";
  Version_index.iter vp
    begin fun vh ->
      let v = Version_index.get_version vh
      and id = Version_index.get_id vh
      in
      cd.cd_print oc " %s %a\n" v (Version_index.scribe_id cd) id
    end;
  Printf.printf "Units:\n";
  Unit_index.iter db.db_unit_index
    begin fun id u _ ->
      cd.cd_print oc " %s %a\n" u (Unit_index.scribe_id cd) id
    end;
  Printf.printf "Architectures:\n";
  Architecture_index.iter db.db_architecture_index
    begin fun id a ->
      cd.cd_print oc " %s %a\n" a (Architecture_index.scribe_id cd) id
    end;
  Printf.printf "Packages:\n";
  Package_index.iter db.db_package_index
    begin fun id ((unit_id, version_id, release_id, architecture_id), p) ->
      let unit_name = Unit_index.find db.db_unit_index unit_id
      and architecture_name = Architecture_index.find db.db_architecture_index architecture_id
      and version = Version_index.get_version (Version_index.find db.db_version_index version_id) 
			and release = Release_index.get_version (Release_index.find db.db_release_index release_id) in
      cd.cd_print oc "  %s'%s%s on %s\n" unit_name version (match release with None -> "" | Some x -> ("-" ^ x)) architecture_name;
      let unit_id' = Unit_index.search db.db_unit_index unit_name in
      let architecture_id' = Architecture_index.search db.db_architecture_index architecture_name in
      let version_id' = Version_index.get_id (Version_index.search db.db_version_index version) in
			let release_id' = Release_index.get_id (Release_index.search db.db_release_index release) in
      let id' = Package_index.search1 db.db_package_index (unit_id', version_id', release_id', architecture_id') in
      cd.cd_print oc "  id=%a id'=%a\n" (Package_index.scribe_id cd) id (Package_index.scribe_id cd) id';
      cd.cd_print oc "%!";
    end;
  ;;
(* ***)
