path: root/lib/management/database.ml

(** Database state: a named collection of relations with a Merkle tree over
    their hashes, a domain registry, and a history chain of prior hashes.
    All mutations produce a new value; no in-place update. *)

(* TODO: history is an unbounded list of hashes; there is no way to
   reconstruct a past state from a hash alone without a separate snapshot
   store. Either cap the history or make it actually useful. *)

module RelationMap = Map.Make(String)

type deferred_entry = {
  relation_name : string;
  constraint_name : string;
  body : Constraint.t;
}

type t = {
  hash : Conventions.Hash.t;
  name : Conventions.Name.t;
  tree : Merkle.t;
  relations : Relation.t RelationMap.t;
  domains : Domain.t RelationMap.t;
  history : Conventions.Hash.t list;
  timestamp : float;
  deferred : deferred_entry list;
}

let empty ~name = {
  hash = "";
  name;
  tree = Merkle.empty;
  relations = RelationMap.empty;
  domains = RelationMap.empty;
  history = [];
  timestamp = Unix.gettimeofday ();
  deferred = [];
}

let compute_hash db =
  match Merkle.root_hash db.tree with
  | Some root -> root
  | None -> Conventions.Hash.hash_text db.name

let max_history = 128

let rec take_at_most n = function
  | []      -> []
  | _  when n = 0 -> []
  | x :: xs -> x :: take_at_most (n - 1) xs

let update_state db ~relations ~tree =
  let new_hash =
    match Merkle.root_hash tree with
    | Some root -> root
    | None -> Conventions.Hash.hash_text db.name
  in
  let history =
    if db.hash = "" then db.history
    else take_at_most max_history (db.hash :: db.history)
  in
  { hash = new_hash; name = db.name; tree; relations;
    domains = db.domains; history; timestamp = Unix.gettimeofday ();
    deferred = db.deferred }

let get_relation db name = RelationMap.find_opt name db.relations

let get_relation_hash db name =
  match RelationMap.find_opt name db.relations with
  | None -> None
  | Some rel -> rel.Relation.hash

let get_relation_names db =
  RelationMap.fold (fun name _ acc -> name :: acc) db.relations []

let has_relation db name = RelationMap.mem name db.relations

(* TODO: computing the hash here for hash:None relations (ephemeral/prelude)
   is a layering violation — callers should assign the hash before calling
   add_relation, not rely on this fallback. *)
let add_relation db ~(relation : Relation.t) =
  let relation_hash = match relation.hash with
    | Some h -> h
    | None ->
      let tree = Option.value relation.tree ~default:Merkle.empty in
      Hashing.hash_relation ~name:relation.name ~schema:relation.schema ~tree
  in
  let relation = { relation with hash = Some relation_hash } in
  let tree = Merkle.insert relation_hash db.tree in
  let relations = RelationMap.add relation.name relation db.relations in
  update_state db ~relations ~tree

let remove_relation db ~name =
  match RelationMap.find_opt name db.relations with
  | None -> db
  | Some relation ->
    let relation_hash = Option.get relation.hash in
    let tree = Merkle.delete relation_hash db.tree in
    let relations = RelationMap.remove name db.relations in
    update_state db ~relations ~tree

let update_relation db ~(relation : Relation.t) =
  let name = relation.name in
  match RelationMap.find_opt name db.relations with
  | None -> db
  | Some old_relation ->
    let old_hash = Option.get old_relation.hash in
    let new_hash = Option.get relation.hash in
    let tree = db.tree |> Merkle.delete old_hash |> Merkle.insert new_hash in
    let relations = RelationMap.add name relation db.relations in
    update_state db ~relations ~tree

let add_domain db (domain : Domain.t) =
  { db with domains = RelationMap.add domain.name domain db.domains }

let get_domain db name = RelationMap.find_opt name db.domains

let get_domain_names db =
  RelationMap.fold (fun name _ acc -> name :: acc) db.domains []

let has_domain db name = RelationMap.mem name db.domains

let remove_domain db name =
  { db with domains = RelationMap.remove name db.domains }