aboutsummaryrefslogtreecommitdiffstats
path: root/lib/kernel/Schema.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/kernel/Schema.ml')
-rw-r--r--lib/kernel/Schema.ml196
1 files changed, 0 insertions, 196 deletions
diff --git a/lib/kernel/Schema.ml b/lib/kernel/Schema.ml
deleted file mode 100644
index e121e7a..0000000
--- a/lib/kernel/Schema.ml
+++ /dev/null
@@ -1,196 +0,0 @@
-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
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 01:10:43 +0000