rework evaluators and add schema scope

16 files changed, 465 insertions, 168 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index e2a9092..b0b3f12 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -75,10 +75,10 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     MultigroupM.find tx branch.multigroups
     |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
 
-  (* [evaluators] is the directory the stored programs of this state run
-     through; they read against this very state, so an earlier state
-     reads as it was. *)
-  class branch ?evaluators storage value node =
+  (* Given [root], the stored programs of this state run through the
+     evaluators registered under it, against this very state, so an
+     earlier state reads as it was. *)
+  class branch ?root storage value node =
     object (self)
       inherit Lifecycle.null
       method to_string = "branch"
@@ -94,7 +94,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
               let* _ = SI.store_blob tx (Representation.to_blob branch'') in
               node_of tx branch' )
         in
-        new branch ?evaluators storage branch'' node' |> Protocols.Handle.make |> Result.ok
+        new branch ?root storage branch'' node' |> Protocols.Handle.make |> Result.ok
 
       method private previous =
         match branch.previous with
@@ -108,16 +108,15 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
       method protocols : Protocols.Handle.protocol list =
         let bind =
-          Option.map
-            (fun evaluators -> Source.bind evaluators ~within:(Protocols.Handle.make {<>}))
-            evaluators
+          Option.map (fun root -> Source.bind root ~within:(Protocols.Handle.make {<>})) root
         in
         let multigroups =
           Prototype.mixture_of node (fun make node ->
               [ MMAddressable.make ~node:(MultigroupM.into node);
-                MMDirectory.make ~storage ~node ~constructor:(M.wrap ?bind storage);
-                MMAssociative.make ~storage ~node:(MultigroupM.into node) ~constructor:(fun node' ->
-                    MultigroupM.from node' |> make |> Result.ok ) ] )
+                MMDirectory.make ~storage ~node ~constructor:(M.load ?bind storage);
+                MMAssociative.make ~admit:M.admit ~storage ~node:(MultigroupM.into node)
+                  ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok)
+                  () ] )
         in
         let open Utilities.Result in
         Protocols.
@@ -148,18 +147,18 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method address = self#hash
     end
 
-  let load ?evaluators tx conn addr =
+  let load ?root tx conn addr =
     let open Utilities.Result in
     let* data = SI.get_req tx (S.Hash addr) in
     let* branch = Representation.of_blob data in
     let* node = node_of tx branch in
-    Ok (new branch ?evaluators conn branch node |> Protocols.Handle.make)
+    Ok (new branch ?root conn branch node |> Protocols.Handle.make)
 
-  let make ?evaluators conn =
+  let make conn =
     let open Utilities.Result in
     SI.with_transaction conn (fun tx ->
         let* empty = MultigroupM.empty_under tx in
         let branch = {multigroups= empty; previous= None} in
         let* _ = SI.store_blob tx (Representation.to_blob branch) in
-        Ok (new branch ?evaluators conn branch MultigroupM.empty |> Protocols.Handle.make) )
+        Ok (new branch conn branch MultigroupM.empty |> Protocols.Handle.make) )
 end
diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli
index 93dd890..865d68d 100644
--- a/lib/kernel/Branch.mli
+++ b/lib/kernel/Branch.mli
@@ -1,16 +1,13 @@
 (** A branch state: its multigroups, and under [previous] the state it
-    succeeded. Given [evaluators], the stored programs read through it
-    run against it. *)
+    succeeded. Given [root], the stored programs read through it run, by
+    the evaluators registered under [root], against it. *)
 module Make (S : Abstract.Storage.STORAGE) : sig
   type t
 
-  val make :
-    ?evaluators:Protocols.Handle.t ->
-    S.connection ->
-    (Protocols.Handle.t, Concepts.Condition.condition) result
+  val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
 
   val load :
-    ?evaluators:Protocols.Handle.t ->
+    ?root:Protocols.Handle.t ->
     S.transaction ->
     S.connection ->
     Concepts.Hash.hash ->
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 052e38a..a371a0c 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -28,7 +28,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let data = Concepts.Hash.blob_of_hash addr in
     S.put tx (S.Label label) data
 
-  class manager ?evaluators storage label head =
+  class manager ?root storage label head =
     object (self)
       inherit Lifecycle.null
       inherit Identity.of_id
@@ -51,7 +51,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
             let* head = Atomic.get head |> M.lookup tx key in
             match head with
             | None -> Ok None
-            | Some head -> B.load ?evaluators tx storage head |> Result.map Option.some )
+            | Some head -> B.load ?root tx storage head |> Result.map Option.some )
 
       method update key reference value =
         let open Utilities.Result in
@@ -92,14 +92,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
             | Error (Some e) -> Error e )
     end
 
-  let make ?evaluators storage label =
+  let make ?root storage label =
     let open Utilities.Result in
     SI.with_transaction storage (fun tx ->
         let* addr = root_for tx label in
         match addr with
-        | None -> Ok (new manager ?evaluators storage label M.empty |> Protocols.Handle.make)
+        | None -> Ok (new manager ?root storage label M.empty |> Protocols.Handle.make)
         | Some addr ->
             let* head = M.find tx addr in
             let* head = Option.to_result ~none:(Error.invalid_root addr) head in
-            Ok (new manager ?evaluators storage label head |> Protocols.Handle.make) )
+            Ok (new manager ?root storage label head |> Protocols.Handle.make) )
 end
diff --git a/lib/kernel/BranchManager.mli b/lib/kernel/BranchManager.mli
index 9fa10ca..873aa36 100644
--- a/lib/kernel/BranchManager.mli
+++ b/lib/kernel/BranchManager.mli
@@ -1,8 +1,8 @@
 (** The heads of the branches, persisted under [label]. Branches it hands
-    out run their stored programs through [evaluators]. *)
+    out run their stored programs by the evaluators under [root]. *)
 module Make (S : Abstract.Storage.STORAGE) : sig
   val make :
-    ?evaluators:Protocols.Handle.t ->
+    ?root:Protocols.Handle.t ->
     S.connection ->
     string ->
     (Protocols.Handle.t, Concepts.Condition.condition) result
diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml
index 692aa7f..518fe4f 100644
--- a/lib/kernel/Initialization.ml
+++ b/lib/kernel/Initialization.ml
@@ -6,33 +6,50 @@ module Error = struct
       ("name" |=| Concepts.Value.String name)
 end
 
-module Make (S : Abstract.Storage.STORAGE) = struct
-  module BM = BranchManager.Make (S)
+let bind namespace (name, handle) =
+  let open Utilities.Result in
+  let* registry = Protocols.Handle.require Protocols.Registry.from namespace in
+  let* bound = Protocols.Registry.update registry name None (Some handle) in
+  if bound then Ok () else Error (Error.taken name)
 
-  let bind namespace (name, handle) =
-    let open Utilities.Result in
-    let* registry = Protocols.Handle.require Protocols.Registry.from namespace in
-    let* bound = Protocols.Registry.update registry name None (Some handle) in
-    if bound then Ok () else Error (Error.taken name)
+let namespace entries =
+  let into = Namespace.make () in
+  let open Utilities.Result in
+  let* () =
+    List.fold_left
+      (fun acc entry ->
+        let* () = acc in
+        bind into entry )
+      (Ok ()) entries
+  in
+  Ok into
 
-  let namespace entries =
-    let open Utilities.Result in
-    let n = Namespace.make () in
-    let* () =
-      List.fold_left
-        (fun acc entry ->
-          let* () = acc in
-          bind n entry )
-        (Ok ()) entries
-    in
-    Ok n
+(* A subsystem's root holds what is its own and not data: its
+   evaluators, and whatever else it registers beside them. *)
+let mount root name =
+  match Path.lookup root Path.(name @/ this) with
+  | Ok mounted -> Ok mounted
+  | Error _ ->
+      let open Utilities.Result in
+      let* mounted = namespace ["evaluator", Namespace.make ()] in
+      let* () = bind root (name, mounted) in
+      Ok mounted
 
-  (* \system keeps the head label it had before subsystems got roots of
-     their own, so a database made then still opens. *)
+module Make (S : Abstract.Storage.STORAGE) = struct
+  module BM = BranchManager.Make (S)
+  module B = Branch.Make (S)
+
+  (* The heads of \system's branches, of which there is always a master,
+     are kept under the label rnt-head. *)
   let initialize ?(evaluators = []) conn =
     let open Utilities.Result in
+    let root = Namespace.make () in
     let* evaluator = namespace evaluators in
-    let* branch = BM.make ~evaluators:evaluator conn "rnt-head" in
+    let* branch = BM.make ~root conn "rnt-head" in
+    let* () =
+      if Path.lookup branch Path.("master" @/ this) |> Result.is_ok then Ok ()
+      else Result.bind (B.make conn) (fun empty -> bind branch ("master", empty))
+    in
     let* system =
       namespace
         [ "branch", branch;
@@ -40,13 +57,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct
           "session", Namespace.make ();
           "application", Namespace.make () ]
     in
-    namespace ["system", system]
-
-  let mount conn root name =
-    let open Utilities.Result in
-    let* evaluators = Path.lookup root Source.evaluators in
-    let* branch = BM.make ~evaluators conn (name ^ "-head") in
-    let* subsystem = namespace ["branch", branch] in
-    let* () = bind root (name, subsystem) in
-    Ok subsystem
+    let* () = bind root ("system", system) in
+    Ok root
 end
diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli
index 97a27f3..a6e6ae0 100644
--- a/lib/kernel/Initialization.mli
+++ b/lib/kernel/Initialization.mli
@@ -1,17 +1,14 @@
+(** a subsystem's root, \[name], holding \[name]\evaluator for the
+    evaluators it registers. Mounting it again gives the one there. *)
+val mount :
+  Protocols.Handle.t -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result
+
 module Make (S : Abstract.Storage.STORAGE) : sig
-  (** the root of the object tree, holding only \system: its branches,
-      the [evaluators] by language, the sessions and the applications. *)
+  (** the root of the object tree, holding \system: its branches, of
+      which there is always a master, the system's [evaluators] by
+      language, the sessions and the applications. *)
   val initialize :
     ?evaluators:(string * Protocols.Handle.t) list ->
     S.connection ->
     (Protocols.Handle.t, Concepts.Condition.condition) result
-
-  (** give a subsystem a root of its own, \[name], with branches of its
-      own whose heads are kept apart from every other root's. Its stored
-      programs run through \system\evaluator. *)
-  val mount :
-    S.connection ->
-    Protocols.Handle.t ->
-    string ->
-    (Protocols.Handle.t, Concepts.Condition.condition) result
 end
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index ecc871e..4530004 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -1,37 +1,12 @@
 module Make (S : Abstract.Storage.STORAGE) = struct
   module SI = Storage.Make (S)
-  module R = SubstantialRelation.Make (S)
-  module E = EphemeralRelation.Make (S)
+  module Sc = Schema.Make (S)
+  module SchemaM = Merkle.Interface (S) (Merkle.StringKey) (Sc)
+  module SMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
+  module SMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Sc)
+  module SMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
 
-  module Entry = struct
-    module Stored = EphemeralRelation.Persisted.Representation
-
-    type t = Substantial of R.t | Ephemeral of EphemeralRelation.Persisted.t
-
-    let encode = function
-      | Substantial relation -> R.encode relation
-      | Ephemeral relation -> Stored.to_blob relation
-
-    let decode blob =
-      let open Utilities.Result in
-      let open Concepts.Encoding in
-      let* data = Bencode.of_blob blob in
-      match data with
-      | Bencode.Tagged (tag, _) when Char.equal tag Stored.tag ->
-          Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation)
-      | _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation)
-
-    let load ?bind storage = function
-      | Substantial relation -> R.load storage relation
-      | Ephemeral relation -> E.load ?bind storage relation
-  end
-
-  module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry)
-  module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
-  module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
-  module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
-
-  type t = {relations: RelationM.address}
+  type t = {schemas: SchemaM.address}
 
   module Error = struct
     open Concepts.Condition
@@ -57,20 +32,25 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let tag = '*'
     let malformed = Error.malformed_multigroup
 
-    let fields {relations} =
+    let fields {schemas} =
       let open Concepts.Encoding in
-      ["relations", Value.bencode_of_hash relations]
+      ["schemas", Value.bencode_of_hash schemas]
 
     let of_fields fields =
       let open Utilities.Result in
       let open Concepts.Encoding in
-      let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
-      Ok {relations}
+      let* schemas = Bencode.field "schemas" fields |> fmap Value.hash_of_bencode in
+      Ok {schemas}
   end
 
   let encode = Representation.to_blob
   let decode = Representation.of_blob
 
+  let node_of tx multigroup =
+    let open Utilities.Result in
+    SchemaM.find tx multigroup.schemas
+    |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup.schemas))
+
   class multigroup ?bind conn value node =
     object (self)
       inherit Lifecycle.null
@@ -88,8 +68,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
         let* node' =
           SI.with_transaction storage (fun tx ->
               let* _ = SI.store_blob tx (Representation.to_blob multigroup') in
-              RelationM.find tx multigroup'.relations
-              |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) )
+              node_of tx multigroup' )
         in
         new multigroup ?bind storage multigroup' node' |> Protocols.Handle.make |> Result.ok
 
@@ -99,37 +78,73 @@ module Make (S : Abstract.Storage.STORAGE) = struct
           [ Addressable.make self;
             Prototype.Associative.(
               of_properties
-                [ ( "relation",
+                [ ( "schema",
                     update_only (fun node' ->
                         Handle.require Addressable.from node'
                         |> Result.map Addressable.address
-                        |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
+                        |> fmap (fun addr -> self#deriving {schemas= addr}) ) ) ] );
             Prototype.Directory.of_properties
-              [ ( "relation",
+              [ ( "schema",
                   Prototype.mixture_of node (fun make node ->
-                      [ RMAddressable.make ~node:(RelationM.into node);
-                        RMDirectory.make ~storage ~node ~constructor:(Entry.load ?bind storage);
-                        RMAssociative.make ~storage ~node:(RelationM.into node)
-                          ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] )
-                ) ] ]
+                      [ SMAddressable.make ~node:(SchemaM.into node);
+                        SMDirectory.make ~storage ~node ~constructor:(Sc.load ?bind storage);
+                        SMAssociative.make ~admit:Sc.admit ~storage ~node:(SchemaM.into node)
+                          ~constructor:(fun node' -> SchemaM.from node' |> make |> Result.ok)
+                          () ] ) ) ] ]
 
       method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
       method address = self#hash
     end
 
-  let wrap ?bind conn value =
+  let load ?bind conn value =
     let open Utilities.Result in
-    let* node =
-      SI.with_transaction conn (fun tx -> RelationM.find tx value.relations)
-      |> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations))
-    in
+    let* node = SI.with_read conn (fun tx -> node_of tx value) in
     new multigroup ?bind conn value node |> Protocols.Handle.make |> Result.ok
 
   let make conn =
     let open Utilities.Result in
     SI.with_transaction conn (fun tx ->
-        let* empty = RelationM.empty_under tx in
-        let multigroup = {relations= empty} in
+        let* empty = SchemaM.empty_under tx in
+        let multigroup = {schemas= empty} in
         let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
-        new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok )
+        new multigroup conn multigroup SchemaM.empty |> Protocols.Handle.make |> Result.ok )
+
+  (* Handed over as the tree shows one, a directory holding its schemas
+     under \schema, a multigroup not stored yet is stored with them. *)
+  let admit _ h =
+    let open Utilities.Result in
+    let* listing = Protocols.Handle.require Protocols.Directory.from h in
+    let* schemas = Protocols.Directory.find listing "schema" in
+    let* schemas =
+      match schemas with
+      | None -> Ok []
+      | Some schemas ->
+          let* listing = Protocols.Handle.require Protocols.Directory.from schemas in
+          let* names = Protocols.Directory.list listing in
+          BatFingerTree.to_list names
+          |> List.filter_map (fun name ->
+              match Protocols.Directory.find listing name with
+              | Ok None -> None
+              | Error c -> Some (Error c)
+              | Ok (Some schema) -> (
+                match Protocols.Addressable.from schema with
+                | Some a ->
+                    let addr = Protocols.Addressable.address a in
+                    Some (Ok (name, fun _ -> Ok addr))
+                | None -> Some (Sc.admit name schema |> Result.map (fun p -> name, p)) ) )
+          |> Utilities.List.sequence
+    in
+    Ok
+      (fun tx ->
+        let* _ = SchemaM.empty_under tx in
+        let* node =
+          SchemaM.with_batch tx (fun () ->
+              List.fold_left
+                (fun node (name, store) ->
+                  let* node = node in
+                  let* addr = store tx in
+                  SchemaM.Tree.insert tx name addr (SchemaM.into node) |> Result.map SchemaM.from )
+                (Ok SchemaM.empty) schemas )
+        in
+        SI.store_blob tx (Representation.to_blob {schemas= SchemaM.hash_of node}) )
 end
diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli
index f8e2555..6dcfb2f 100644
--- a/lib/kernel/Multigroup.mli
+++ b/lib/kernel/Multigroup.mli
@@ -1,16 +1,20 @@
+(** A multigroup: its schemas, \multigroup\[m]\schema\[s]. *)
 module Make (S : Abstract.Storage.STORAGE) : sig
-  type t
+  include Merkle.VALUE
 
-  val encode : t -> Concepts.Blob.t
-  val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
-
-  (** [bind] runs the stored programs read through the multigroup; see
-      [EphemeralRelation.binding]. *)
-  val wrap :
+  val load :
     ?bind:EphemeralRelation.binding ->
     S.connection ->
     t ->
     (Protocols.Handle.t, Concepts.Condition.condition) result
 
+  (** a multigroup handed over with no address, as a directory holding its
+      schemas under \schema, to store once the write has begun. *)
+  val admit :
+    string ->
+    Protocols.Handle.t ->
+    (S.transaction Prototype.Associative.admission, Concepts.Condition.condition) result
+
+  (** an empty one, stored. *)
   val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
 end
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index d6a65c9..db3d17d 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -24,7 +24,7 @@ module Error = struct
       ("path" |=| Concepts.Value.String (to_string path))
 end
 
-let walking f g handle path =
+let walking ?missing f g handle path =
   let rec walk handle = function
     | [] -> g handle
     | x :: xs -> (
@@ -37,7 +37,8 @@ let walking f g handle path =
         in
         let* elem = Directory.find dir x in
         match elem with
-        | None -> Error (Error.path_not_found path)
+        | None -> (
+          match missing with Some m -> m () | None -> Error (Error.path_not_found path) )
         | Some elem -> f x handle (fun () -> walk elem xs) )
   in
   walk handle path
@@ -53,6 +54,13 @@ let releasing root handle f =
 
 let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path
 
+let find handle path =
+  walking
+    ~missing:(fun () -> Ok None)
+    (fun _ parent -> releasing handle parent)
+    (fun h -> Ok (Some h))
+    handle path
+
 let update handle path key reference value =
   let open Utilities.Result in
   let open Protocols in
@@ -61,6 +69,36 @@ let update handle path key reference value =
       let* registry = Handle.require Registry.from target in
       Registry.update registry key reference value )
 
+(* The changes at this object, and those beneath each child they reach. *)
+let split changes =
+  let here, below = List.partition (fun (path, _, _) -> path = []) changes in
+  let segments =
+    List.fold_left
+      (fun segments (path, _, _) ->
+        let x = List.hd path in
+        if List.mem x segments then segments else segments @ [x] )
+      [] below
+  in
+  let beneath x =
+    List.filter_map
+      (fun (path, key, value) ->
+        match path with y :: rest when y = x -> Some (rest, key, value) | _ -> None )
+      below
+  in
+  here, List.map (fun x -> x, beneath x) segments
+
+(* What is not there yet is handed over as a directory of what the
+   changes put in it, for its parent to store. *)
+let rec fresh changes =
+  let here, children = split changes in
+  Prototype.(
+    mixture
+      [ Directory.of_properties
+          ( List.filter_map (fun (_, key, value) -> Option.map (fun v -> key, v) value) here
+          @ List.map (fun (x, beneath) -> x, fresh beneath) children ) ] )
+
+let binds changes = List.exists (fun (_, _, value) -> Option.is_some value) changes
+
 (* Changes under the same name are applied to the child together, so
    every object on the way is derived once however many changes reach
    it: a batch of changes to a branch is one successor state. *)
@@ -73,35 +111,25 @@ let assoc_all handle changes =
     Ok (Handle.from a')
   in
   let rec apply prefix node changes =
-    let here, below = List.partition (fun (path, _, _) -> path = []) changes in
-    let segments =
-      List.fold_left
-        (fun segments (path, _, _) ->
-          let x = List.hd path in
-          if List.mem x segments then segments else segments @ [x] )
-        [] below
-    in
-    let beneath x =
-      List.filter_map
-        (fun (path, key, value) ->
-          match path with y :: rest when y = x -> Some (rest, key, value) | _ -> None )
-        below
-    in
+    let here, below = split changes in
+    let segments = List.map fst below in
     match List.find_opt (fun (_, key, _) -> List.mem key segments) here with
     | Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key]))
     | None ->
         let* children =
           List.map
-            (fun x ->
+            (fun (x, beneath) ->
               let* dir = Handle.require Directory.from node in
               let* found = Directory.find dir x in
               match found with
-              | None -> Error (Error.path_not_found (prefix @ [x]))
+              | None when binds beneath -> Ok [x, Some (fresh beneath)]
+              | None -> Ok []
               | Some child ->
-                  releasing handle child (fun () -> apply (prefix @ [x]) child (beneath x))
-                  |> Result.map (fun child' -> x, Some child') )
-            segments
+                  releasing handle child (fun () -> apply (prefix @ [x]) child beneath)
+                  |> Result.map (fun child' -> [x, Some child']) )
+            below
           |> Utilities.List.sequence
+          |> Result.map List.concat
         in
         (* each step derives from the last; only the steps in between are
            ours to release *)
diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli
index e331b3a..e95505d 100644
--- a/lib/kernel/Path.mli
+++ b/lib/kernel/Path.mli
@@ -7,6 +7,10 @@ val to_list : t -> string list
 val to_string : t -> string
 val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
 
+(** what [path] reaches, or [None] when some part of it is not there. *)
+val find :
+  Protocols.Handle.t -> t -> (Protocols.Handle.t option, Concepts.Condition.condition) result
+
 val update :
   Protocols.Handle.t ->
   t ->
@@ -25,7 +29,9 @@ val assoc :
   (Protocols.Handle.t, Concepts.Condition.condition) result
 
 (** every change of [assoc] at once: each object on the way is derived
-    once, so the changes to a branch land as one successor state. *)
+    once, so the changes to a branch land as one successor state. An
+    object on the way that is not there yet is handed to its parent as a
+    directory of what the changes put in it. *)
 val assoc_all :
   Protocols.Handle.t ->
   (t * string * Protocols.Handle.t option) list ->
diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml
index 4c96bc3..3fd208e 100644
--- a/lib/kernel/Prototype.ml
+++ b/lib/kernel/Prototype.ml
@@ -47,24 +47,38 @@ module Associative = struct
 
   let update_only f = function None -> Error (Error.deletion_not_supported ()) | Some x -> f x
 
+  type 'tx admission = 'tx -> (Concepts.Hash.hash, Concepts.Condition.condition) result
+
   module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) = struct
     module Tree = Merkle.Make (S) (K)
     module SI = Storage.Make (S)
 
-    let make ~storage ~constructor ~node =
+    (* A value with no address yet is [admit]ted: it is read here, before
+       the write begins, since reading it may itself need storage, and
+       stored by the write. *)
+    let make ?admit ~storage ~constructor ~node () =
       Protocols.Associative.make
       @@ object
            method update key value =
-             (* TODO: read-only transactions *)
+             let open Utilities.Result in
+             let open Protocols in
+             let* store =
+               match value with
+               | None -> Ok None
+               | Some h -> (
+                 match Addressable.from h, admit with
+                 | None, Some admit -> admit key h |> Result.map Option.some
+                 | _ ->
+                     let* addressable = Handle.require Addressable.from h in
+                     let addr = Addressable.address addressable in
+                     Ok (Some (fun _ -> Ok addr)) )
+             in
              SI.with_transaction storage (fun tx ->
-                 let open Utilities.Result in
-                 let open Protocols in
                  let* node' =
-                   match value with
+                   match store with
                    | None -> Tree.remove tx key node
-                   | Some h ->
-                       let* addressable = Handle.require Addressable.from h in
-                       let addr = Addressable.address addressable in
+                   | Some store ->
+                       let* addr = store tx in
                        Tree.insert tx key addr node
                  in
                  constructor node' )
@@ -92,10 +106,10 @@ module Directory = struct
     let make ~storage ~constructor ~node =
       Protocols.Directory.make
       @@ object
-           method list = SI.with_transaction storage (Fun.flip Tree.keys node)
+           method list = SI.with_read storage (Fun.flip Tree.keys node)
 
            method find k =
-             SI.with_transaction storage (fun tx -> Tree.lookup tx k node)
+             SI.with_read storage (fun tx -> Tree.lookup tx k node)
              |> Utilities.Result.fmap (function
                | None -> Ok None
                | Some x -> constructor x |> Result.map Option.some )
diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli
index db22b63..5f0e29e 100644
--- a/lib/kernel/Prototype.mli
+++ b/lib/kernel/Prototype.mli
@@ -32,13 +32,23 @@ module Associative : sig
     Protocols.Handle.t option ->
     (Protocols.Handle.t, Concepts.Condition.condition) result
 
+  (** how a value is stored once a write has begun, giving its address. *)
+  type 'tx admission = 'tx -> (Concepts.Hash.hash, Concepts.Condition.condition) result
+
   module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) : sig
     module Tree : module type of Merkle.Make (S) (K)
 
+    (** a value bound under a key must have an address, unless [admit]
+        can read it, before the write begins, into an admission. *)
     val make :
+      ?admit:
+        (string ->
+        Protocols.Handle.t ->
+        (S.transaction admission, Concepts.Condition.condition) result ) ->
       storage:S.connection ->
       constructor:(Tree.node -> (Protocols.Handle.t, Concepts.Condition.condition) result) ->
       node:Tree.node ->
+      unit ->
       Protocols.Handle.protocol
   end
 end
diff --git a/lib/kernel/Schema.ml b/lib/kernel/Schema.ml
new file mode 100644
index 0000000..e121e7a
--- /dev/null
+++ b/lib/kernel/Schema.ml
@@ -0,0 +1,196 @@
+module Make (S : Abstract.Storage.STORAGE) = struct
+  module SI = Storage.Make (S)
+  module R = SubstantialRelation.Make (S)
+  module E = EphemeralRelation.Make (S)
+
+  (* A relation as a schema holds it. *)
+  module Entry = struct
+    module Stored = EphemeralRelation.Persisted.Representation
+
+    type t = Substantial of R.t | Ephemeral of EphemeralRelation.Persisted.t
+
+    let encode = function
+      | Substantial relation -> R.encode relation
+      | Ephemeral relation -> Stored.to_blob relation
+
+    let decode blob =
+      let open Utilities.Result in
+      let open Concepts.Encoding in
+      let* data = Bencode.of_blob blob in
+      match data with
+      | Bencode.Tagged (tag, _) when Char.equal tag Stored.tag ->
+          Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation)
+      | _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation)
+
+    let load ?bind storage = function
+      | Substantial relation -> R.load storage relation
+      | Ephemeral relation -> E.load ?bind storage relation
+
+    (* A program is stored as itself, to run whenever it is read; any
+       other relation is stored as the tuples it holds now. *)
+    let admit name h =
+      let open Utilities.Result in
+      let address entry = Concepts.Hash.hash_of_blob (encode entry) in
+      match EphemeralRelation.stored h with
+      | Some (evaluator, code, _) ->
+          let* description = Protocols.Relation.heading h in
+          Ok
+            (fun tx ->
+              let* record = E.store tx ~name ~evaluator ~code description in
+              Ok (address (Ephemeral record)) )
+      | None ->
+          let* description, tuples = Protocols.Relation.read h in
+          Ok
+            (fun tx ->
+              let* relation = R.store tx description tuples in
+              Ok (address (Substantial relation)) )
+  end
+
+  module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry)
+  module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
+  module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
+  module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
+
+  type t = {relations: RelationM.address}
+
+  module Error = struct
+    open Concepts.Condition
+
+    let malformed_schema () =
+      condition "malformed-schema"
+        "The on-disk representation of a schema did not conform to what was expected. Is your \
+         database corrupted?"
+        empty
+
+    let incomplete_schema addr =
+      condition "incomplete-schema"
+        "A stored schema is missing part of its expected structure. Is your storage corrupted?"
+        ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
+  end
+
+  module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
+    Concepts.Encoding.Record.Make (Body)
+
+  and Body : Concepts.Encoding.Record.BODY = struct
+    type nonrec t = t
+
+    let tag = 'S'
+    let malformed = Error.malformed_schema
+
+    let fields {relations} =
+      let open Concepts.Encoding in
+      ["relations", Value.bencode_of_hash relations]
+
+    let of_fields fields =
+      let open Utilities.Result in
+      let open Concepts.Encoding in
+      let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
+      Ok {relations}
+  end
+
+  let encode = Representation.to_blob
+  let decode = Representation.of_blob
+
+  let node_of tx schema =
+    let open Utilities.Result in
+    RelationM.find tx schema.relations
+    |> fmap (Option.to_result ~none:(Error.incomplete_schema schema.relations))
+
+  class schema ?bind conn value node =
+    object (self)
+      inherit Lifecycle.null
+      method to_string = "schema"
+      val schema = value
+      val storage = conn
+      val node = node (* FIXME: see the comment on Branch.ml *)
+
+      (* TODO: Add later to the lifecycle management, accounting for
+         derived instances. Callers must release the previous handle
+         when done with it so its instance can be cleaned up after the
+         last reference is released. *)
+      method deriving schema' =
+        let open Utilities.Result in
+        let* node' =
+          SI.with_transaction storage (fun tx ->
+              let* _ = SI.store_blob tx (Representation.to_blob schema') in
+              node_of tx schema' )
+        in
+        new schema ?bind storage schema' node' |> Protocols.Handle.make |> Result.ok
+
+      method protocols : Protocols.Handle.protocol list =
+        let open Utilities.Result in
+        Protocols.
+          [ Addressable.make self;
+            Prototype.Associative.(
+              of_properties
+                [ ( "relation",
+                    update_only (fun node' ->
+                        Handle.require Addressable.from node'
+                        |> Result.map Addressable.address
+                        |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
+            Prototype.Directory.of_properties
+              [ ( "relation",
+                  Prototype.mixture_of node (fun make node ->
+                      [ RMAddressable.make ~node:(RelationM.into node);
+                        RMDirectory.make ~storage ~node ~constructor:(Entry.load ?bind storage);
+                        RMAssociative.make ~admit:Entry.admit ~storage ~node:(RelationM.into node)
+                          ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok)
+                          () ] ) ) ] ]
+
+      method hash = Representation.to_blob schema |> Concepts.Hash.hash_of_blob
+      method address = self#hash
+    end
+
+  let load ?bind conn value =
+    let open Utilities.Result in
+    let* node = SI.with_read conn (fun tx -> node_of tx value) in
+    new schema ?bind conn value node |> Protocols.Handle.make |> Result.ok
+
+  let make conn =
+    let open Utilities.Result in
+    SI.with_transaction conn (fun tx ->
+        let* empty = RelationM.empty_under tx in
+        let schema = {relations= empty} in
+        let* _ = SI.store_blob tx (Representation.to_blob schema) in
+        new schema conn schema RelationM.empty |> Protocols.Handle.make |> Result.ok )
+
+  (* Handed over as the tree shows one, a directory holding its relations
+     under \relation, a schema not stored yet is stored with them. *)
+  let admit _ h =
+    let open Utilities.Result in
+    let* listing = Protocols.Handle.require Protocols.Directory.from h in
+    let* relations = Protocols.Directory.find listing "relation" in
+    let* relations =
+      match relations with
+      | None -> Ok []
+      | Some relations ->
+          let* listing = Protocols.Handle.require Protocols.Directory.from relations in
+          let* names = Protocols.Directory.list listing in
+          BatFingerTree.to_list names
+          |> List.filter_map (fun name ->
+              match Protocols.Directory.find listing name with
+              | Ok None -> None
+              | Error c -> Some (Error c)
+              | Ok (Some relation) -> (
+                match Protocols.Addressable.from relation with
+                | Some a ->
+                    let addr = Protocols.Addressable.address a in
+                    Some (Ok (name, fun _ -> Ok addr))
+                | None -> Some (Entry.admit name relation |> Result.map (fun p -> name, p)) ) )
+          |> Utilities.List.sequence
+    in
+    Ok
+      (fun tx ->
+        let* _ = RelationM.empty_under tx in
+        let* node =
+          RelationM.with_batch tx (fun () ->
+              List.fold_left
+                (fun node (name, store) ->
+                  let* node = node in
+                  let* addr = store tx in
+                  RelationM.Tree.insert tx name addr (RelationM.into node)
+                  |> Result.map RelationM.from )
+                (Ok RelationM.empty) relations )
+        in
+        SI.store_blob tx (Representation.to_blob {relations= RelationM.hash_of node}) )
+end
diff --git a/lib/kernel/Schema.mli b/lib/kernel/Schema.mli
new file mode 100644
index 0000000..7970ee2
--- /dev/null
+++ b/lib/kernel/Schema.mli
@@ -0,0 +1,23 @@
+(** A schema: its relations, \schema\[s]\relation\[r]. For now only a
+    namespace for them. *)
+module Make (S : Abstract.Storage.STORAGE) : sig
+  include Merkle.VALUE
+
+  val load :
+    ?bind:EphemeralRelation.binding ->
+    S.connection ->
+    t ->
+    (Protocols.Handle.t, Concepts.Condition.condition) result
+
+  (** a schema handed over with no address, as a directory holding its
+      relations under \relation, to store once the write has begun. A
+      relation with no address is stored as a program if it is one, and
+      as the tuples it holds if not. *)
+  val admit :
+    string ->
+    Protocols.Handle.t ->
+    (S.transaction Prototype.Associative.admission, Concepts.Condition.condition) result
+
+  (** an empty one, stored. *)
+  val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
+end
diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml
index 4bce1ac..1abd278 100644
--- a/lib/kernel/Session.ml
+++ b/lib/kernel/Session.ml
@@ -2,7 +2,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   module SI = Storage.Make (S)
   module B = Branch.Make (S)
 
-  class session ?evaluators storage state =
+  class session storage state =
     object (self)
       inherit Lifecycle.exclusive
       inherit Identity.of_id
@@ -18,11 +18,10 @@ module Make (S : Abstract.Storage.STORAGE) = struct
         function
         | "branch" ->
             SI.with_read storage (fun tx ->
-                B.load ?evaluators tx storage (Atomic.get state).Protocols.Session.snapshot )
+                B.load tx storage (Atomic.get state).Protocols.Session.snapshot )
             |> Result.map Option.some
         | _ -> Ok None
     end
 
-  let make ?evaluators storage state =
-    new session ?evaluators storage state |> Protocols.Handle.make
+  let make storage state = new session storage state |> Protocols.Handle.make
 end
diff --git a/lib/kernel/Session.mli b/lib/kernel/Session.mli
index 77c7d5d..be4451b 100644
--- a/lib/kernel/Session.mli
+++ b/lib/kernel/Session.mli
@@ -1,4 +1,3 @@
 module Make (S : Abstract.Storage.STORAGE) : sig
-  val make :
-    ?evaluators:Protocols.Handle.t -> S.connection -> Protocols.Session.state -> Protocols.Handle.t
+  val make : S.connection -> Protocols.Session.state -> Protocols.Handle.t
 end