diff options
43 files changed, 1586 insertions, 293 deletions
diff --git a/lib/Scratch.ml b/lib/Scratch.ml new file mode 100644 index 0000000..0779db3 --- /dev/null +++ b/lib/Scratch.ml @@ -0,0 +1,23 @@ +module LMDB = Backend.Storage.LMDB +module I = Kernel.Initialization.Make (LMDB) + +let rec remove path = + if Sys.is_directory path then begin + Array.iter (fun name -> remove (Filename.concat path name)) (Sys.readdir path); + Sys.rmdir path + end + else Sys.remove path + +let root ?(evaluators = ["fol", Evaluators.FOL.make ()]) () = + let open Utilities.Result in + let directory = Filename.temp_dir "rnt-scratch" "" in + let* connection = + Sexplib.Sexp.( + List [Atom "lmdb"; List [Atom "path"; Atom directory]; List [Atom "mode"; Atom "420"]] ) + |> Concepts.Configuration.term_of_sexp + |> LMDB.connect + in + at_exit (fun () -> + LMDB.disconnect connection; + try remove directory with Sys_error _ -> () ); + I.initialize ~evaluators connection diff --git a/lib/Scratch.mli b/lib/Scratch.mli new file mode 100644 index 0000000..804c2c2 --- /dev/null +++ b/lib/Scratch.mli @@ -0,0 +1,7 @@ +(** a root over a database of its own in a temporary directory, removed + when the program exits: for tests, and for trying things out. Its + system evaluators are [evaluators], FOL unless told otherwise. *) +val root : + ?evaluators:(string * Protocols.Handle.t) list -> + unit -> + (Protocols.Handle.t, Concepts.Condition.condition) result diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index 17dda3f..3b38b93 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -43,6 +43,9 @@ module C = struct let mdb_env_close = foreign "mdb_env_close" (ptr mdb_env @-> returning void) + let mdb_env_set_mapsize = + foreign "mdb_env_set_mapsize" (ptr mdb_env @-> size_t @-> returning mdb_result) + let mdb_dbi_open = foreign "mdb_dbi_open" (ptr mdb_txn @-> ptr char @-> uint @-> ptr mdb_dbi @-> returning mdb_result) @@ -166,6 +169,7 @@ let connect (c : Concepts.Configuration.term) = let* () = ensure_directory path (directory_mode mode) in begin let* env = C.mdb_env_create' () in + let* () = C.mdb_env_set_mapsize env (Unsigned.Size_t.of_int (1 lsl 30)) in (* NOTLS ties readers to transactions rather than threads, so one thread can hold several read transactions (nested cursors). *) match C.mdb_env_open env path C.Flags.mdb_notls (PosixTypes.Mode.of_int mode) with diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml index b7aa814..82c207f 100644 --- a/lib/concepts/Mode.ml +++ b/lib/concepts/Mode.ml @@ -1,30 +1,18 @@ -type attribute = string type attributes = BatSet.String.t -type affordance = Decides | Generates of Cardinality.t -type mode = {bound: attributes; affords: affordance} +type mode = {bound: attributes; yields: Cardinality.t} type t = mode list -let attributes_of_list = BatSet.String.of_list -let attributes_of_map map = BatMap.String.keys map |> BatSet.String.of_enum -let decides_when bound = {bound= attributes_of_list bound; affords= Decides} -let enumerable cardinality = {bound= BatSet.String.empty; affords= Generates cardinality} -let of_list modes = modes +let mode bound yields = {bound= BatSet.String.of_list bound; yields} -let generation declaration bound = +let generation modes bound = List.fold_left - (fun tightest {bound= declared; affords} -> - match affords with - | Generates cardinality when BatSet.String.subset declared bound -> - Some (Option.fold ~none:cardinality ~some:(Cardinality.meet cardinality) tightest) - | Generates _ | Decides -> tightest ) - None declaration + (fun tightest {bound= declared; yields} -> + if BatSet.String.subset declared bound then + Some (Option.fold ~none:yields ~some:(Cardinality.meet yields) tightest) + else tightest ) + None modes -let exhaustible declaration bound = - Option.fold ~none:false ~some:Cardinality.exhaustible (generation declaration bound) +let exhaustible modes bound = + Option.fold ~none:false ~some:Cardinality.exhaustible (generation modes bound) -let decision declaration bound = - exhaustible declaration bound - || List.exists - (fun {bound= declared; affords} -> - match affords with Decides -> BatSet.String.equal declared bound | Generates _ -> false ) - declaration +let project attributes = List.filter (fun {bound; _} -> BatSet.String.subset bound attributes) diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli index 6a906d1..d91b2ab 100644 --- a/lib/concepts/Mode.mli +++ b/lib/concepts/Mode.mli @@ -1,27 +1,14 @@ -type attribute = string type attributes = BatSet.String.t -(** what asking a relation under a given set of bound attributes - affords. The answer is to whether anything satisfies the binding, - or the bindings of the attributes left free together with the - class of what is produced. *) -type affordance = Decides | Generates of Cardinality.t +(** given [bound], every matching tuple can be produced, and there are + at most [yields]. *) +type mode = {bound: attributes; yields: Cardinality.t} -type mode = {bound: attributes; affords: affordance} -type t +type t = mode list -val attributes_of_list : attribute list -> attributes -val attributes_of_map : 'a BatMap.String.t -> attributes -val decides_when : attribute list -> mode -val enumerable : Cardinality.t -> mode -val of_list : mode list -> t - -(** the tightest class declared for generating under [bound]. A mode - declared for fewer bound attributes applies to more, since the - attributes left free are then fewer and no more numerous. *) +val mode : string list -> Cardinality.t -> mode val generation : t -> attributes -> Cardinality.t option - val exhaustible : t -> attributes -> bool -(** declared outright, or implied by a generation that can be exhausted. *) -val decision : t -> attributes -> bool +(** the modes still usable when only [attributes] can be bound. *) +val project : attributes -> t -> t diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml index 28dadc5..c2da77c 100644 --- a/lib/concepts/Tuple.ml +++ b/lib/concepts/Tuple.ml @@ -39,3 +39,8 @@ and Body : Encoding.Record.BODY = struct end let hash tuple = Representation.to_blob tuple |> Hash.hash_of_blob + +let to_string {attributes; _} = + BatMap.String.bindings attributes + |> List.map (fun (a, v) -> a ^ "=" ^ Value.to_string v) + |> String.concat " " diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml index e436eeb..9e204a9 100644 --- a/lib/evaluators/FOL.ml +++ b/lib/evaluators/FOL.ml @@ -8,9 +8,8 @@ module Error = struct let cancelled () = condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty - let not_a_plan name = - condition "not-a-fol-program" "The evaluator was given an object that carries no FOL plan" - ("object" |=| Concepts.Value.String name) + let not_a_plan () = + condition "not-a-fol-program" "The evaluator was given a program of another kind" empty let not_a_relation name = condition "not-a-relation" "A plan named an object that does not describe itself as a relation" @@ -28,10 +27,6 @@ module Error = struct condition "malformed-fol-program" "A stored FOL program did not conform to what was expected. Is your database corrupted?" empty - let foreign_program evaluator = - condition "foreign-program" "A plan named a relation stored by another evaluator" - ("evaluator" |=| Concepts.Value.String evaluator) - let cyclic_program code = condition "cyclic-program" "A stored program reads itself" ("program" |=| Concepts.Value.String (Concepts.Hash.to_hum_string code)) @@ -41,7 +36,7 @@ let name = "fol" type 'r term = Base of 'r | Project of 'r term * string BatFingerTree.t type plan = Protocols.Handle.t term -type Protocols.Handle.protocol += Plan of plan +type Kernel.Program.kind += Fol of Kernel.Path.t term module Bencode = Concepts.Encoding.Bencode @@ -71,52 +66,38 @@ let rec term_of_bencode = Ok (Project (term, BatFingerTree.of_list attributes)) | _ -> Error (Error.malformed_program ()) -let encode term = bencode_of_term term |> Bencode.to_blob -let decode code = Bencode.of_blob code |> Utilities.Result.fmap term_of_bencode - -let stored relation = - Protocols.Handle.into relation (function - | Kernel.EphemeralRelation.Stored {evaluator; code} -> Some (evaluator, code) - | _ -> None ) - |> Option.map (fun stored -> Protocols.Handle.invoke stored Fun.id) +let encode term = bencode_of_term term |> Bencode.to_bytes |> Bytes.to_string +let decode source = Bencode.of_bytes (Bytes.of_string source) |> Utilities.Result.fmap term_of_bencode (* TODO: To strenghten our checks for self references, we need to construct a graph and see raise a condition if there are self references. We partially do that here with the program calling self, but if the flow is alternated, say between program A and B, where B calls A and A calls B, we also must check. *) -let instantiate resolve = +let instantiate within = let open Utilities.Result in let rec bind expanding = function | Base reference -> ( - let* relation = resolve reference in - match stored relation with + let* relation = Kernel.Path.lookup within reference in + match Kernel.Program.image relation with | None -> Ok (Base relation) - | Some (evaluator, code) -> + | Some {kind= Fol term; source; _} -> Protocols.Handle.release relation; - let identity = Concepts.Hash.hash_of_blob code in - if not (String.equal evaluator name) then Error (Error.foreign_program evaluator) - else if List.exists (Concepts.Hash.hash_equals identity) expanding then + let identity = Concepts.Hash.hash_of_bytes (Bytes.of_string source) in + if List.exists (Concepts.Hash.hash_equals identity) expanding then Error (Error.cyclic_program identity) - else - let* term = decode code in - bind (identity :: expanding) term ) + else bind (identity :: expanding) term + | Some _ -> + Protocols.Handle.releasing relation (fun () -> + let* program = Protocols.Executable.require relation in + let* result = Protocols.Executable.invoke program [] ~within in + Ok (Base result) ) ) | Project (term, attributes) -> let* plan = bind expanding term in Ok (Project (plan, attributes)) in bind [] -class program plan = - object - inherit Kernel.Lifecycle.null - inherit Kernel.Identity.of_id - method to_string = "fol-program" - method protocols : Protocols.Handle.protocol list = [Plan plan] - end - -let program plan = new program plan |> Protocols.Handle.make - let restrict attributes description = let open Utilities.Result in BatFingerTree.fold_left @@ -140,6 +121,17 @@ let rec describe = | _ -> Error (Error.not_a_relation (Protocols.Handle.to_string relation)) ) | Project (plan, attributes) -> describe plan |> fmap (restrict attributes) +let rec modes = + let open Utilities.Result in + function + | Base relation -> + let* relation = Protocols.Relation.require relation in + Protocols.Relation.modes relation + | Project (plan, attributes) -> + modes plan + |> Result.map + (Concepts.Mode.project (BatSet.String.of_list (BatFingerTree.to_list attributes))) + let enumerate relation = let open Utilities.Result in let* enumerable = Protocols.Enumerable.require relation in @@ -173,37 +165,48 @@ let project description relation = in Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce) -let derive relation description enumerate = - Kernel.EphemeralRelation.instantiate ~inputs:[relation] description +let contains relation tuple = + Result.bind (Protocols.Relation.require relation) (fun r -> Protocols.Relation.contains r tuple) + +let derive ?decide relation description modes enumerate = + Kernel.EphemeralRelation.instantiate ~inputs:[relation] ?decide + ~modes:(fun () -> Ok modes) + description {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; program= None} (fun () -> enumerate relation) let rec execute plan = let open Utilities.Result in let* description = describe plan in + let* modes = modes plan in match plan with | Base relation -> let* relation = Protocols.Handle.copy relation |> Option.to_result ~none:(Error.released_relation (Protocols.Handle.to_string relation)) in - Ok (derive relation description enumerate) + Ok (derive ~decide:(contains relation) relation description modes enumerate) | Project (plan, _) -> let* relation = execute plan in - Ok (derive relation description (project description)) + Ok (derive relation description modes (project description)) class evaluator = object (self) inherit Kernel.Lifecycle.null inherit Kernel.Identity.of_id method to_string = "fol-evaluator" + method parse source = decode source |> Result.map (fun term -> Fol term) - method invoke program = - Protocols.Handle.into program (function Plan plan -> Some plan | _ -> None) - |> Option.to_result ~none:(Error.not_a_plan (Protocols.Handle.to_string program)) - |> Utilities.Result.fmap (fun plan -> Protocols.Handle.invoke plan execute) + method eval kind _inputs ~within = + let open Utilities.Result in + match kind with + | Fol term -> + let* plan = instantiate within term in + execute plan + | _ -> Error (Error.not_a_plan ()) method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self] end let make () = new evaluator |> Protocols.Handle.make +let program ?root term = Kernel.Program.make ?root ~evaluator:name ~source:(encode term) (Fol term) diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index b0ba06e..25c2e7b 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -1,9 +1,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct - (* Branch has a name, a set of multigroups, and a backlink to the previous state - multigroup has a name and a set of schemas - schema has a name and a set of relations + (* A branch state holds its multigroups and a backlink to the state it + succeeded, each multigroup its relations: - \branch\master\multigroup\universe\schema\sky\relation\planet + \system\branch\master\multigroup\universe\relation\planet + \system\branch\master\previous\multigroup\universe\relation\planet *) module SI = Storage.Make (S) @@ -70,7 +70,15 @@ module Make (S : Abstract.Storage.STORAGE) = struct let pointer_of hash = SI.Pointer.make Loader.load (S.Hash hash) - class branch storage value node = + let node_of tx branch = + let open Utilities.Result in + MultigroupM.find tx branch.multigroups + |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups)) + + (* 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" @@ -84,15 +92,52 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* node' = SI.with_transaction storage (fun tx -> let* _ = SI.store_blob tx (Representation.to_blob branch'') in - MultigroupM.find tx branch'.multigroups - |> fmap (Option.to_result ~none:(Error.incomplete_branch branch'.multigroups)) ) + node_of tx branch' ) in - new branch 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 + | None -> Ok None + | Some pointer -> + SI.with_read storage (fun tx -> + let open Utilities.Result in + let* previous = SI.Pointer.deref tx pointer in + let* node = node_of tx previous in + Ok (Some (Protocols.Handle.make {<branch = previous; node>})) ) method protocols : Protocols.Handle.protocol list = + let bind = + Option.map + (fun root -> {EphemeralRelation.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.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 + let admits (m, multigroup) = + Protocols.Handle.releasing multigroup (fun () -> + let* admission = Protocols.Admission.require multigroup in + let* violations = Protocols.Admission.check admission in + Ok + (List.map + (fun (d, witness) -> + Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), witness ) + violations ) ) + in Protocols. [ Addressable.make self; + Admission.make + object + method check = + let* named = Prototype.Directory.children multigroups in + List.map admits named |> Utilities.List.sequence |> Result.map List.concat + end; Prototype.Associative.( of_properties [ ( "multigroup", @@ -100,28 +145,31 @@ module Make (S : Abstract.Storage.STORAGE) = struct Handle.require Addressable.from node' |> Result.map Addressable.address |> fmap (fun addr -> self#deriving {branch with multigroups= addr}) ) ) ] ); - Prototype.Directory.of_properties - [ ( "multigroup", - Prototype.mixture_of node (fun make node -> - [ MMAddressable.make ~node:(MultigroupM.into node); - MMDirectory.make ~storage ~node ~constructor:(M.wrap storage); - MMAssociative.make ~storage ~node:(MultigroupM.into node) - ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok ) - ] ) ) ] ] + Directory.make + object + method list = + Ok + (BatFingerTree.of_list + ( "multigroup" + :: Option.fold ~none:[] ~some:(fun _ -> ["previous"]) branch.previous ) ) + + method find = + function + | "multigroup" -> Ok (Some multigroups) + | "previous" -> self#previous + | _ -> Ok None + end ] method hash = Representation.to_blob branch |> Concepts.Hash.hash_of_blob method address = self#hash end - let load 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 = - MultigroupM.find tx branch.multigroups - |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups)) - in - Ok (new branch conn branch node |> Protocols.Handle.make) + let* node = node_of tx branch in + Ok (new branch ?root conn branch node |> Protocols.Handle.make) let make conn = let open Utilities.Result in diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli index c08e781..865d68d 100644 --- a/lib/kernel/Branch.mli +++ b/lib/kernel/Branch.mli @@ -1,9 +1,13 @@ +(** A branch state: its multigroups, and under [previous] the state 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 : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result val load : + ?root:Protocols.Handle.t -> S.transaction -> S.connection -> Concepts.Hash.hash -> diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index 3531748..886d100 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -6,8 +6,21 @@ module Error = struct "The root hash for the database state is missing from the backend. Either your storage is \ corrupted, or this is a bug in RNT!" ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head)) + + let refused violations = + condition "refused" "The state is not admitted: a denial in it holds tuples" + (List.fold_left + (fun ps (path, witness) -> + ps & path |=| Concepts.Value.String (Concepts.Tuple.to_string witness) ) + empty violations ) end +let admitted state = + let open Utilities.Result in + let* admission = Protocols.Admission.require state in + let* violations = Protocols.Admission.check admission in + if violations = [] then Ok () else Error (Error.refused violations) + module Make (S : Abstract.Storage.STORAGE) = struct module M = Merkle.Make (S) (Merkle.StringKey) module SI = Storage.Make (S) @@ -28,7 +41,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 storage label head = + class manager ?root storage label head = object (self) inherit Lifecycle.null inherit Identity.of_id @@ -51,11 +64,14 @@ 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 tx storage head |> Result.map Option.some ) + | Some head -> B.load ?root tx storage head |> Result.map Option.some ) + (* a head moves only to an admitted state, judged before the head is + taken, since judging may run stored programs that read storage *) method update key reference value = let open Utilities.Result in let open Protocols in + let* () = Option.fold ~none:(Ok ()) ~some:admitted value in SI.with_transaction storage (fun tx -> match Utilities.Atomic.mswap head (fun head -> @@ -92,14 +108,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct | Error (Some e) -> Error e ) end - let make 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 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 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 a75875f..873aa36 100644 --- a/lib/kernel/BranchManager.mli +++ b/lib/kernel/BranchManager.mli @@ -1,3 +1,9 @@ +(** The heads of the branches, persisted under [label]. Branches it hands + out run their stored programs by the evaluators under [root]. *) module Make (S : Abstract.Storage.STORAGE) : sig - val make : S.connection -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result + val make : + ?root:Protocols.Handle.t -> + S.connection -> + string -> + (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml index 1d9267e..c0ec241 100644 --- a/lib/kernel/EphemeralRelation.ml +++ b/lib/kernel/EphemeralRelation.ml @@ -7,8 +7,6 @@ type t = | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ]; program: program option } -type Protocols.Handle.protocol += Stored of {evaluator: string; code: Concepts.Blob.t} - module Error = struct open Concepts.Condition @@ -20,8 +18,12 @@ module Error = struct let unbound_program name = condition "unbound-program" - "A stored relation has to be instantiated by its evaluator before it can be enumerated" + "A relation generated by a program has to be given a state to run within before it is read" ("relation" |=| Concepts.Value.String name) + + let undecidable_membership () = + condition "undecidable-membership" + "A relation with no membership test and no end was asked whether it holds a tuple" empty end module Persisted = struct @@ -61,7 +63,7 @@ let persisted = function Some {Persisted.name; schematics; program} | _ -> None -class ephemeral_relation ?code description value enumerate inputs = +class ephemeral_relation ?program ?decide description value modes enumerate inputs = object (self) inherit Lifecycle.counted inherit Identity.of_id @@ -69,64 +71,134 @@ class ephemeral_relation ?code description value enumerate inputs = val relation : t = value method destroy = List.iter Protocols.Handle.release inputs method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate () + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = modes () method describe () = Ok (Protocols.Schematics.Relation description) - (* TODO: We do not need to scan, but simply apply a membership - criteria (set of constraints. For now this works, but it's - inneficient and hurts data independence, as there is an - assymetry between ephemeral and substantial relations. *) method contains (tuple : Concepts.Tuple.t) = let open Utilities.Result in - let* cursor = self#enumerate in - Fun.protect - ~finally:(fun () -> Protocols.Handle.release cursor) - (fun () -> - let* scan = Protocols.Cursor.require cursor in - Protocols.Cursor.exists scan (fun member -> - Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) ) + match decide with + | Some decide -> decide tuple + | None -> + let* modes = self#modes in + if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then + Error (Error.undecidable_membership ()) + else + let* cursor = self#enumerate in + Protocols.Handle.releasing cursor (fun () -> + let* scan = Protocols.Cursor.require cursor in + Protocols.Cursor.exists scan (fun member -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash member) + (Concepts.Tuple.hash tuple) ) ) method protocols : Protocols.Handle.protocol list = - let protocols = Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] in + let protocols = + Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] + @ Option.fold ~none:[] ~some:Protocols.Handle.protocols program + in match persisted relation with | None -> protocols | Some record -> - let stored = - Option.fold ~none:protocols - ~some:(fun code -> Stored {evaluator= record.program.evaluator; code} :: protocols) - code - in Protocols.Addressable.make object method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob end - :: stored + :: protocols end -let instantiate ?(inputs = []) ?code description value enumerate = - new ephemeral_relation ?code description value enumerate inputs |> Protocols.Handle.make +let instantiate ?(inputs = []) ?program ?decide ~modes description value enumerate = + new ephemeral_relation ?program ?decide description value modes enumerate inputs + |> Protocols.Handle.make + +let literal description tuples = + instantiate description + ~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length tuples)))]) + {name= None; schematics= `Temporary description; program= None} + (fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ()))) + +type binding = {root: Protocols.Handle.t; within: Protocols.Handle.t} + +(* The relation a program produced has to outlive the cursor over it. *) +let enumerate_owned relation = + let open Utilities.Result in + let owner = + object + method reference = true + method release = Protocols.Handle.release relation + method is_managed = true + end + in + match + let* enumerable = Protocols.Enumerable.require relation in + Protocols.Enumerable.enumerate enumerable + with + | Error c -> Protocols.Handle.release relation; Error c + | Ok cursor -> + Ok + (Protocols.Handle.make + object + inherit Lifecycle.retaining cursor owner + method to_string = Protocols.Handle.to_string cursor + end ) + +let asking f relation = + Protocols.Handle.releasing relation (fun () -> Result.bind (Protocols.Relation.require relation) f) + +(* What a program generates is known only from the relation it + returns, so reading it, asking its modes and asking for a tuple + all invoke it. *) +let generated ?program ?within name description value = + let invoking f () = + let open Utilities.Result in + match program, within with + | Some program, Some within -> + let* executable = Protocols.Executable.require program in + Result.bind (Protocols.Executable.invoke executable [] ~within) f + | _ -> Error (Error.unbound_program name) + in + instantiate ?program + ~decide:(fun tuple -> invoking (asking (fun r -> Protocols.Relation.contains r tuple)) ()) + ~modes:(invoking (asking Protocols.Relation.modes)) + description value (invoking enumerate_owned) + +let of_program ?within description program = + generated ~program ?within (Protocols.Handle.to_string program) description + {name= None; schematics= `Temporary description; program= None} module Make (S : Abstract.Storage.STORAGE) = struct module SI = Storage.Make (S) module R = SubstantialRelation.Make (S) - let restore ~code ({Persisted.name; schematics; program} : Persisted.t) description = - instantiate ~code description - {name= Some name; schematics= `Persisted schematics; program= Some program} - (fun () -> Error (Error.unbound_program name)) - - let load connection (record : Persisted.t) = - SI.with_read connection (fun tx -> - let open Utilities.Result in - let* description = R.schema_of tx record.schematics in - let* code = SI.get_req tx (S.Hash record.program.code) in - Ok (restore ~code record description) ) - - let persist connection ~name ~evaluator ~code description = + let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t) + description = + generated ?program ?within name description + {name= Some name; schematics= `Persisted schematics; program= Some pointer} + + let load ?bind connection (record : Persisted.t) = + let open Utilities.Result in + let* description, source = + SI.with_read connection (fun tx -> + let* description = R.schema_of tx record.schematics in + let* code = SI.get_req tx (S.Hash record.program.code) in + Ok (description, Bytes.to_string (Concepts.Blob.bytes_of_blob code)) ) + in + match bind with + | None -> Ok (restore record description) + | Some {root; within} -> + let* program = Program.load root ~evaluator:record.program.evaluator ~source in + Ok (restore ~program ~within record description) + + let store tx ~name ~evaluator ~source description = + let open Utilities.Result in + let* schematics = R.store_schema tx description in + let* address = SI.store_blob tx (Concepts.Blob.blob_of_bytes (Bytes.of_string source)) in + let record = {Persisted.name; schematics; program= {evaluator; code= address}} in + let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in + Ok record + + let persist connection ~name program description = + let open Utilities.Result in + let* {Program.evaluator; source; _} = Program.require program in SI.with_transaction connection (fun tx -> - let open Utilities.Result in - let* schematics = R.store_schema tx description in - let* address = SI.store_blob tx code in - let record = {Persisted.name; schematics; program= {evaluator; code= address}} in - let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in - Ok (restore ~code record description) ) + let* record = store tx ~name ~evaluator ~source description in + Ok (restore ~program record description) ) end diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index 3c8addb..518fe4f 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -1,23 +1,62 @@ +module Error = struct + open Concepts.Condition + + let taken name = + condition "name-taken" "A namespace already binds the name" + ("name" |=| Concepts.Value.String name) +end + +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 + +(* 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 + 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 open Protocols in let root = Namespace.make () in - let registry = Registry.from root |> Option.get in - let* branch_manager = BM.make conn "rnt-head" in - let* _ = Registry.update registry "branch" None (Some branch_manager) in - let evaluator_namespace = Namespace.make () in - let evaluator_registry = Registry.from evaluator_namespace |> Option.get in - let* _ = - List.fold_left - (fun acc (name, handle) -> - let* _ = acc in - Registry.update evaluator_registry name None (Some handle) ) - (Ok true) evaluators + let* evaluator = namespace evaluators 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; + "evaluator", evaluator; + "session", Namespace.make (); + "application", Namespace.make () ] in - let* _ = Registry.update registry "evaluator" None (Some evaluator_namespace) in - let* _ = Registry.update registry "session" None (Some (Namespace.make ())) in + let* () = bind root ("system", system) in Ok root end diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli index 926bbd8..a6e6ae0 100644 --- a/lib/kernel/Initialization.mli +++ b/lib/kernel/Initialization.mli @@ -1,4 +1,12 @@ +(** 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 \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 -> diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index af5b19f..4235914 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -323,8 +323,6 @@ functor let* _ = persist tx new_root in Ok new_root - let remove tx key node = failwith "TODO" [@@warning "-27"] - let rec fold_left tx f acc = let open Utilities.Result in function @@ -342,6 +340,53 @@ functor let keys tx node = fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node + + let excise i ft = + let fl, fr = BatFingerTree.split_at ft i in + BatFingerTree.append fl (BatFingerTree.tail_exn fr) + + (* Like an insert, produces a new tree where the path to the key + is copied without it, and a node it leaves empty goes from its + parent with the key that separated it. *) + let rec remove' tx key node = + let open Utilities.Result in + match node with + | Leaf {keys; values} -> + let i, _ = lookup1 keys key in + if BatFingerTree.size keys = 1 then Ok None + else + let leaf = Leaf {keys= excise i keys; values= excise i values} in + let* _ = persist tx leaf in + Ok (Some leaf) + | Trunk {keys; children} -> + let i, found = lookup1 keys key in + let i = if found then i + 1 else i in + let* child = BatFingerTree.get children i |> find' tx in + let* child = remove' tx key child in + let trunk = + match child with + | Some child -> Trunk {keys; children= BatFingerTree.set children i (hash_of child)} + | None -> Trunk {keys= excise (max 0 (i - 1)) keys; children= excise i children} + in + let* _ = persist tx trunk in + Ok (Some trunk) + + let rec shrink tx = function + | Trunk {children; _} when BatFingerTree.size children = 1 -> + Utilities.Result.fmap (shrink tx) (find' tx (BatFingerTree.get children 0)) + | node -> Ok node + + let remove tx key node = + let open Utilities.Result in + let* present = lookup tx key node in + if Option.is_none present then Ok node + else + let* node = remove' tx key node in + match node with + | None -> + let* _ = persist tx empty in + Ok empty + | Some node -> shrink tx node end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index 1417a65..f01a983 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -3,6 +3,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct module R = SubstantialRelation.Make (S) module E = EphemeralRelation.Make (S) + (* A relation as a multigroup holds it. *) module Entry = struct module Stored = EphemeralRelation.Persisted.Representation @@ -21,17 +22,39 @@ module Make (S : Abstract.Storage.STORAGE) = struct Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation) | _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation) - let load storage = function + let load ?bind storage = function | Substantial relation -> R.load storage relation - | Ephemeral relation -> E.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 Program.image h with + | Some {evaluator; source; _} -> + let* description = Protocols.Relation.heading h in + Ok + (fun tx -> + let* record = E.store tx ~name ~evaluator ~source 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 + (* A schema is only a name: \schema\[s] is the tree of its relations, + with no record of its own. *) + module T = Merkle.Make (S) (Merkle.StringKey) module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry) - module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey) + module TAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey) + module TAssociative = Prototype.Associative.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: T.address; denials: T.address} module Error = struct open Concepts.Condition @@ -42,42 +65,144 @@ module Make (S : Abstract.Storage.STORAGE) = struct database corrupted?" empty - let incomplete_multigroup addr = + let incomplete addr = condition "incomplete-multigroup" "A stored multigroup 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) + let unjudgeable denial = + condition "unjudgeable-denial" + "A denial does not declare that reading it with nothing bound ends, so the state cannot \ + be judged" + ("denial" |=| Concepts.Value.String denial) + end - and Body : Concepts.Encoding.Record.BODY = struct + module Representation = Concepts.Encoding.Record.Make (struct type nonrec t = t let tag = '*' let malformed = Error.malformed_multigroup - let fields {relations} = + let fields {schemas; denials} = let open Concepts.Encoding in - ["relations", Value.bencode_of_hash relations] + ["schemas", Value.bencode_of_hash schemas; "denials", Value.bencode_of_hash denials] 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* schemas = Bencode.field "schemas" fields |> fmap Value.hash_of_bencode in + let* denials = Bencode.field "denials" fields |> fmap Value.hash_of_bencode in + Ok {schemas; denials} + end) let encode = Representation.to_blob let decode = Representation.of_blob - class multigroup conn value node = + let node_of tx addr = + let open Utilities.Result in + T.find tx addr |> fmap (Option.to_result ~none:(Error.incomplete addr)) + + (* What [h] holds under [property], each to store once the write has + begun, and the tree they make when it has. *) + let admissions property admit h = + let open Utilities.Result in + let* listing = Protocols.Handle.require Protocols.Directory.from h in + let* found = Protocols.Directory.find listing property in + let* children = Option.fold ~none:(Ok []) ~some:Prototype.Directory.children found in + List.map + (fun (name, child) -> + Prototype.Associative.admission admit name child |> Result.map (fun p -> name, p) ) + children + |> Utilities.List.sequence + + let tree_of tx admissions = + let open Utilities.Result in + let* _ = T.empty_under tx in + T.with_batch tx (fun () -> + List.fold_left + (fun node (name, store) -> + let* node = node in + let* addr = store tx in + T.insert tx name addr node ) + (Ok T.empty) admissions ) + + let admit_schema _ h = + let open Utilities.Result in + let* relations = admissions "relation" Entry.admit h in + Ok (fun tx -> Result.map T.hash_of (tree_of tx relations)) + + let relations ?bind storage node = + Prototype.mixture_of node (fun make node -> + [ TAddressable.make ~node; + RMDirectory.make ~storage ~node:(RelationM.from node) + ~constructor:(Entry.load ?bind storage); + TAssociative.make ~admit:Entry.admit ~storage ~node ~constructor:(fun node' -> + Ok (make node') ) ] ) + + let rec schema ?bind storage node = + let open Utilities.Result in + Prototype.mixture + [ TAddressable.make ~node; + Prototype.Directory.of_properties ["relation", relations ?bind storage node]; + Prototype.Associative.( + of_properties + [ ( "relation", + update_only (fun relations' -> + let* a = Protocols.Handle.require Protocols.Addressable.from relations' in + let* node' = + SI.with_read storage (fun tx -> node_of tx (Protocols.Addressable.address a)) + in + Ok (schema ?bind storage node') ) ) ] ) ] + + let schemas ?bind storage node = + Prototype.mixture_of node (fun make node -> + [ TAddressable.make ~node; + Protocols.Directory.make + object + method list = SI.with_read storage (Fun.flip T.keys node) + + method find name = + let open Utilities.Result in + SI.with_read storage (fun tx -> + let* found = T.lookup tx name node in + match found with + | None -> Ok None + | Some addr -> + let* relations = node_of tx addr in + Ok (Some (schema ?bind storage relations)) ) + end; + TAssociative.make ~admit:admit_schema ~storage ~node ~constructor:(fun node' -> + Ok (make node') ) ] ) + + let trees tx {schemas; denials} = + let open Utilities.Result in + let* schemas = node_of tx schemas in + let* denials = node_of tx denials in + Ok (schemas, denials) + + let held (name, relation) = + let open Utilities.Result in + Protocols.Handle.releasing relation (fun () -> + let* denial = Protocols.Relation.require relation in + let* modes = Protocols.Relation.modes denial in + if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then + Error (Error.unjudgeable name) + else + let* enumerable = Protocols.Enumerable.require relation in + let* cursor = Protocols.Enumerable.enumerate enumerable in + Protocols.Handle.releasing cursor (fun () -> + let* scan = Protocols.Cursor.require cursor in + let* first = Protocols.Cursor.next scan in + Ok (Option.to_list (Option.map (fun witness -> name, witness) first)) ) ) + + class multigroup ?bind conn value schema_tree denial_tree = object (self) inherit Lifecycle.null method to_string = "multigroup" val multigroup = value val storage = conn - val node = node (* FIXME: see the comment on Branch.ml *) + val schema_tree = schema_tree (* FIXME: see the comment on Branch.ml *) + val denial_tree = denial_tree (* TODO: Add later to the lifecycle management, accounting for derived instances. Callers must release the previous handle @@ -85,51 +210,65 @@ module Make (S : Abstract.Storage.STORAGE) = struct last reference is released. *) method deriving multigroup' = let open Utilities.Result in - let* node' = + let* schemas', denials' = 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)) ) + let* _ = SI.store_blob tx (encode multigroup') in + trees tx multigroup' ) in - new multigroup storage multigroup' node' |> Protocols.Handle.make |> Result.ok + new multigroup ?bind storage multigroup' schemas' denials' + |> Protocols.Handle.make + |> Result.ok + + method check = + let open Utilities.Result in + let* named = Prototype.Directory.children (relations ?bind storage denial_tree) in + List.map held named |> Utilities.List.sequence |> Result.map List.concat method protocols : Protocols.Handle.protocol list = let open Utilities.Result in + let derive f node' = + Protocols.Handle.require Protocols.Addressable.from node' + |> Result.map Protocols.Addressable.address + |> fmap (fun addr -> self#deriving (f addr)) + in Protocols. [ Addressable.make self; + Admission.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}) ) ) ] ); + [ "schema", update_only (derive (fun addr -> {multigroup with schemas= addr})); + "denial", update_only (derive (fun addr -> {multigroup with denials= 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 storage); - RMAssociative.make ~storage ~node:(RelationM.into node) - ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] ) - ) ] ] - - method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob + [ "schema", schemas ?bind storage schema_tree; + "denial", relations ?bind storage denial_tree ] ] + + method hash = encode multigroup |> Concepts.Hash.hash_of_blob method address = self#hash end - let wrap 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 - new multigroup conn value node |> Protocols.Handle.make |> Result.ok + let* schemas, denials = SI.with_read conn (fun tx -> trees tx value) in + new multigroup ?bind conn value schemas denials |> 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* _ = SI.store_blob tx (Representation.to_blob multigroup) in - new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok ) + let* empty = T.empty_under tx in + let multigroup = {schemas= empty; denials= empty} in + let* _ = SI.store_blob tx (encode multigroup) in + new multigroup conn multigroup T.empty T.empty |> Protocols.Handle.make |> Result.ok ) + + (* Handed over as the tree shows one, a directory holding its schemas + under \schema and its denials under \denial, a multigroup not stored + yet is stored with them. *) + let admit _ h = + let open Utilities.Result in + let* schemas = admissions "schema" admit_schema h in + let* denials = admissions "denial" Entry.admit h in + Ok + (fun tx -> + let* schemas = tree_of tx schemas in + let* denials = tree_of tx denials in + SI.store_blob tx (encode {schemas= T.hash_of schemas; denials= T.hash_of denials}) ) end diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli index 2df41e6..fab02df 100644 --- a/lib/kernel/Multigroup.mli +++ b/lib/kernel/Multigroup.mli @@ -1,8 +1,22 @@ +(** A multigroup: its schemas, \multigroup\[m]\schema\[s], and its denials, + \multigroup\[m]\denial\[d]. *) 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 - val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result + 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 and its denials under \denial, 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 2e712cc..0814b1c 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -17,9 +17,14 @@ module Error = struct let path_not_found path = condition "path-not-found" "A given path was not found under the specified object" ("path" |=| Concepts.Value.String (to_string path)) + + let overlapping_change path = + condition "overlapping-change" + "A batch of changes both replaced an object and changed inside it" + ("path" |=| Concepts.Value.String (to_string path)) end -let walking f g handle path = +let walking ?missing f g handle path = let open Protocols in let open Utilities.Result in let rec walk handle = function @@ -32,7 +37,8 @@ let walking f g handle path = in let* elem = Directory.find dir x |> Result.map (Option.map Handle.autorelease) 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 Handle.with_autorelease (fun () -> @@ -42,6 +48,13 @@ let walking f g handle path = let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path +let find handle path = + walking + ~missing:(fun () -> Ok None) + (fun _ _ f -> f ()) + (fun h -> Ok (Some h)) + handle path + let update handle path key reference value = let open Utilities.Result in let open Protocols in @@ -49,16 +62,116 @@ let update handle path key reference value = let* registry = Handle.require Registry.from target in Registry.update registry key reference value -let assoc handle path key 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.sort_uniq String.compare (List.map (fun (path, _, _) -> List.hd path) 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. *) +let assoc_all handle changes = let open Utilities.Result in - let open Utilities.Fun in let open Protocols in - let assoc_on handle key value = - let* a = Handle.require Associative.from handle in + let assoc_on node (key, value) = + let* a = Handle.require Associative.from node in let* a' = Associative.update a key value in Ok (Handle.from a') in - walking - (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some)) - (fun h -> assoc_on h key value) - handle path + let rec apply prefix node changes = + 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, beneath) -> + let* dir = Handle.require Directory.from node in + let* found = Directory.find dir x in + match found with + | None when binds beneath -> Ok [x, Some (fresh beneath)] + | None -> Ok [] + | Some child -> + Handle.releasing 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 *) + List.fold_left + (fun current change -> + let* current = current in + let* next = assoc_on current change in + if current != node then Handle.release current; + Ok next ) + (Ok node) + (children @ List.map (fun (_, key, value) -> key, value) here) + in + apply [] handle changes + +let assoc handle path key value = assoc_all handle [path, key, value] + +let diff a b = + let open Utilities.Result in + let open Protocols in + let address h = Option.map Addressable.address (Addressable.from h) in + let same x y = + match address x, address y with + | Some p, Some q -> Concepts.Hash.hash_equals p q + | _ -> Handle.equal x y + in + let names h = + let* dir = Handle.require Directory.from h in + let* names = Directory.list dir in + Ok (BatFingerTree.to_list names) + in + let find h name = + let* dir = Handle.require Directory.from h in + Directory.find dir name + in + let rec walk prefix a b = + let* left = names a in + let* right = names b in + List.sort_uniq String.compare (left @ right) + |> List.map (fun name -> + let path = prefix @ [name] in + let* x = find a name in + let* y = find b name in + Fun.protect + ~finally:(fun () -> List.iter Handle.release (Option.to_list x @ Option.to_list y)) + (fun () -> + match x, y with + | None, None -> Ok [] + | Some x, Some y when same x y -> Ok [] + | Some x, Some y when Directory.from x <> None && Directory.from y <> None -> + let* below = walk path x y in + Ok (if below = [] then [path] else below) + | _ -> Ok [path] ) ) + |> Utilities.List.sequence + |> Result.map List.concat + in + walk [] a b diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli index 571e59c..e95505d 100644 --- a/lib/kernel/Path.mli +++ b/lib/kernel/Path.mli @@ -4,8 +4,13 @@ val this : t val ( @/ ) : string -> t -> t val of_list : string list -> t 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 -> @@ -14,9 +19,26 @@ val update : Protocols.Handle.t option -> (bool, Concepts.Condition.condition) result +(** [assoc handle path key value] derives [handle] with [key] under + [path] bound to [value], or unbound when [None]. *) val assoc : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> (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. 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 -> + (Protocols.Handle.t, Concepts.Condition.condition) result + +(** the paths, relative to [a] and [b], that differ between them. Equal + addresses are not descended, so this costs what changed. Every child + is compared, so diff a branch's \multigroup rather than the branch, + whose \previous differs whenever anything does. *) +val diff : Protocols.Handle.t -> Protocols.Handle.t -> (t list, Concepts.Condition.condition) result diff --git a/lib/kernel/Program.ml b/lib/kernel/Program.ml new file mode 100644 index 0000000..64a9fcf --- /dev/null +++ b/lib/kernel/Program.ml @@ -0,0 +1,74 @@ +(* A program is an image just like PE, but we represent it as an + object. It should have the kind of executable it is, indicating the + evaluator needed for it to be executed and a type (generally it can + be a tree) that can be interpreted/compiled by said evaluator, and + finally the source code in plain text so we can display it for + debug. We can persist programs under + \system\branch\<b>\multigroup\<m>\program\, but we are not + obligated to, they can be merely temporary in memory. *) + +module Error = struct + open Concepts.Condition + + let unloaded evaluator = + condition "unloaded-program" "A program has to be given a root before it can be run" + ("evaluator" |=| Concepts.Value.String evaluator) + + let no_evaluator evaluator = + condition "no-evaluator" "No evaluator is registered under that name" + ("evaluator" |=| Concepts.Value.String evaluator) + + let not_a_program name = + condition "not-a-program" "A handle was expected to carry a program and did not" + ("object" |=| Concepts.Value.String name) +end + +type kind = Protocols.Evaluator.kind = .. +type image = {evaluator: string; kind: kind; source: string} +type Protocols.Handle.protocol += Program of image + +let image handle = + Protocols.Handle.into handle (function Program image -> Some image | _ -> None) + |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id) + +let reference evaluator = + match String.rindex_opt evaluator ':' with + | None -> "system", evaluator + | Some i -> + String.sub evaluator 0 i, String.sub evaluator (i + 1) (String.length evaluator - i - 1) + +let require handle = + image handle |> Option.to_result ~none:(Error.not_a_program (Protocols.Handle.to_string handle)) + +let with_evaluator root evaluator f = + let open Utilities.Result in + let scope, language = reference evaluator in + let* found = + Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this) + |> Result.map_error (fun _ -> Error.no_evaluator evaluator) + in + Protocols.Handle.releasing found (fun () -> Result.bind (Protocols.Evaluator.require found) f) + +class program ?root image = + object (self) + inherit Lifecycle.null + inherit Identity.of_id + method to_string = image.source + + method invoke inputs ~within = + let open Utilities.Result in + let* root = Option.to_result ~none:(Error.unloaded image.evaluator) root in + with_evaluator root image.evaluator (fun evaluator -> + Protocols.Evaluator.eval evaluator image.kind inputs ~within ) + + method protocols : Protocols.Handle.protocol list = + [Program image; Protocols.Executable.make self] + end + +let make ?root ~evaluator ~source kind = + new program ?root {evaluator; kind; source} |> Protocols.Handle.make + +let load root ~evaluator ~source = + with_evaluator root evaluator (fun found -> + Protocols.Evaluator.parse found source + |> Result.map (make ~root ~evaluator ~source) ) diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml index 4c96bc3..ea1083b 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 + + (* 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 admission admit key h = + match Protocols.Addressable.from h with + | Some a -> + let addr = Protocols.Addressable.address a in + Ok (fun _ -> Ok addr) + | None -> admit key h + 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 = + let make ~admit ~storage ~constructor ~node = Protocols.Associative.make @@ object method update key value = - (* TODO: read-only transactions *) + let open Utilities.Result in + let* store = + match value with + | None -> Ok None + | Some h -> admission admit key h |> Result.map Option.some + 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' ) @@ -81,6 +95,17 @@ module Directory = struct method find k = Ok (BatMap.find_opt k props) end + let children directory = + let open Utilities.Result in + let* listing = Protocols.Handle.require Protocols.Directory.from directory in + let* names = Protocols.Directory.list listing in + BatFingerTree.to_list names + |> List.map (fun name -> + let* found = Protocols.Directory.find listing name in + Ok (Option.map (fun child -> name, child) found) ) + |> Utilities.List.sequence + |> Result.map (List.filter_map Fun.id) + module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) @@ -92,10 +117,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..9c446fc 100644 --- a/lib/kernel/Prototype.mli +++ b/lib/kernel/Prototype.mli @@ -6,6 +6,10 @@ val mixture : Protocols.Handle.protocol list -> Protocols.Handle.t module Directory : sig val of_properties : (string * Protocols.Handle.t) list -> Protocols.Handle.protocol + (** the names a directory lists, and what each reaches. *) + val children : + Protocols.Handle.t -> ((string * Protocols.Handle.t) list, Concepts.Condition.condition) result + module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) @@ -32,10 +36,26 @@ 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 + + (** a value with an address is stored as that address; [admit] reads + one with none, before the write begins, into an admission. *) + val admission : + (string -> Protocols.Handle.t -> ('tx admission, Concepts.Condition.condition) result) -> + string -> + Protocols.Handle.t -> + ('tx admission, 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 is stored as its [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 -> diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml new file mode 100644 index 0000000..23698ba --- /dev/null +++ b/lib/kernel/Scope.ml @@ -0,0 +1,152 @@ +type home = {multigroup: string; schema: string} + +class type implementation = object + method branch : Protocols.Handle.t + method home : home + method previous : (Protocols.Handle.t option, Concepts.Condition.condition) result + method catalog : (string list, Concepts.Condition.condition) result +end + +type Protocols.Handle.protocol += Scope of implementation + +let require handle = + Protocols.Handle.into handle (function Scope i -> Some i | _ -> None) + |> Option.to_result + ~none: + Concepts.Condition.( + condition "not-a-scope" "A handle was expected to be a branch state read from a home" + empty ) + +let relations {multigroup; schema} = + Path.("multigroup" @/ multigroup @/ "schema" @/ schema @/ "relation" @/ this) + +let path home relation = Path.(of_list (to_list (relations home) @ [relation])) +let denial multigroup = Path.("multigroup" @/ multigroup @/ "denial" @/ this) + +(* A name leaves out, from the left, what it shares with its home. *) +let resolve home text = + match String.split_on_char ':' text with + | names when List.mem "" names -> None + | [r] -> Some (home, r) + | [s; r] -> Some ({home with schema= s}, r) + | [m; s; r] -> Some ({multigroup= m; schema= s}, r) + | _ -> None + +let locate home text = Option.map (fun (h, r) -> path h r) (resolve home text) + +let attribute home relation text = + match List.rev (String.split_on_char ':' text) with + | [a] -> Some a + | a :: rest when resolve home (String.concat ":" (List.rev rest)) = resolve home relation -> + Some a + | _ -> None + +(* every relation of a branch state, as multigroup:schema:relation *) +let catalog_of branch = + let open Utilities.Result in + let name prefix last = String.concat ":" (List.rev (last :: prefix)) in + let rec down prefix handle properties = + let* level = Path.find handle Path.(List.hd properties @/ this) in + match level, List.tl properties with + | None, _ -> Ok [] + | Some level, [] -> + let* listing = Protocols.Handle.require Protocols.Directory.from level in + let* names = Protocols.Directory.list listing in + Ok (List.map (name prefix) (BatFingerTree.to_list names)) + | Some level, rest -> + let* named = Prototype.Directory.children level in + List.map (fun (n, child) -> down (n :: prefix) child rest) named + |> Utilities.List.sequence + |> Result.map List.concat + in + down [] branch ["multigroup"; "schema"; "relation"] + +let rec make branch home = + Prototype.mixture + [ Protocols.Directory.make + object + method list = + let open Utilities.Result in + let* found = Path.find branch (relations home) in + match found with + | None -> Ok BatFingerTree.empty + | Some found -> + let* listing = Protocols.Handle.require Protocols.Directory.from found in + Protocols.Directory.list listing + + (* what is not a relation's name names no relation here *) + method find text = + match resolve home text with + | None -> Ok None + | Some (h, r) -> Path.find branch (path h r) + end; + Scope + object + method branch = branch + method home = home + + method previous = + let open Utilities.Result in + let* previous = Path.find branch Path.("previous" @/ this) in + Ok (Option.map (fun p -> make p home) previous) + + method catalog = catalog_of branch + end ] + +let heads = Path.("system" @/ "branch" @/ this) + +let of_root root ~branch home = + let open Utilities.Result in + let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in + Ok (make state home) + +let branch i = Protocols.Handle.invoke i (fun o -> o#branch) +let home i = Protocols.Handle.invoke i (fun o -> o#home) +let previous i = Protocols.Handle.invoke i (fun o -> o#previous) +let catalog i = Protocols.Handle.invoke i (fun o -> o#catalog) + +module Error = struct + open Concepts.Condition + + let malformed name = + condition "malformed-name" + "A relation is named relation, schema:relation or multigroup:schema:relation" + ("name" |=| Concepts.Value.String name) + + let malformed_denial name = + condition "malformed-name" "A denial is named denial or multigroup:denial" + ("name" |=| Concepts.Value.String name) + + let moved branch = + condition "serialization-conflict" "The branch moved on while this commit was made; retry it" + ("branch" |=| Concepts.Value.String branch) +end + +let publish ?(denials = []) root ~branch ~home bindings = + let open Utilities.Result in + let* changes = + List.map + (fun (name, v) -> + match resolve home name with + | Some (h, r) -> Ok (relations h, r, v) + | None -> Error (Error.malformed name) ) + bindings + |> Utilities.List.sequence + in + let* denied = + List.map + (fun (name, v) -> + match String.split_on_char ':' name with + | [d] when d <> "" -> Ok (denial home.multigroup, d, v) + | [m; d] when m <> "" && d <> "" -> Ok (denial m, d, v) + | _ -> Error (Error.malformed_denial name) ) + denials + |> Utilities.List.sequence + in + let changes = changes @ denied in + if List.is_empty changes then Ok () + else + let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in + let* next = Path.assoc_all state changes in + let* landed = Path.update root heads branch (Some state) (Some next) in + if landed then Ok () else Error (Error.moved branch) diff --git a/lib/kernel/Scope.mli b/lib/kernel/Scope.mli new file mode 100644 index 0000000..83b3309 --- /dev/null +++ b/lib/kernel/Scope.mli @@ -0,0 +1,71 @@ +(** A branch state read from a home: a [Directory] of relations where + [R] names the home schema's, [s:R] a schema's of the home multigroup, + and [m:s:R] anyone's in the branch state. It lists the home schema. *) + +type home = {multigroup: string; schema: string} + +class type implementation = object + (** the branch state read *) + method branch : Protocols.Handle.t + + method home : home + + (** the same home in the state before, if there is one *) + method previous : (Protocols.Handle.t option, Concepts.Condition.condition) result + + (** every relation of the branch state, as [m:s:R] *) + method catalog : (string list, Concepts.Condition.condition) result +end + +type Protocols.Handle.protocol += Scope of implementation + +val make : Protocols.Handle.t -> home -> Protocols.Handle.t + +(** [home] in the head of \system\branch\[branch]. *) +val of_root : + Protocols.Handle.t -> + branch:string -> + home -> + (Protocols.Handle.t, Concepts.Condition.condition) result + +val require : + Protocols.Handle.t -> + (implementation Protocols.Handle.interface, Concepts.Condition.condition) result + +val branch : implementation Protocols.Handle.interface -> Protocols.Handle.t +val home : implementation Protocols.Handle.interface -> home + +val previous : + implementation Protocols.Handle.interface -> + (Protocols.Handle.t option, Concepts.Condition.condition) result + +val catalog : + implementation Protocols.Handle.interface -> (string list, Concepts.Condition.condition) result + +(** \multigroup\[m]\schema\[s]\relation, from a branch state. *) +val relations : home -> Path.t + +(** \multigroup\[m]\schema\[s]\relation\[relation], from a branch state. *) +val path : home -> string -> Path.t + +(** where [text] names a relation, read from [home], from a branch state. *) +val locate : home -> string -> Path.t option + +(** the attribute [text] names of the relation named [relation], both read + from [home]: bare, or qualified with a name of that relation. *) +val attribute : home -> string -> string -> string option + +(** bind each named relation to its value, or unbind it on [None], in the + head of \system\branch\[branch], as one successor state. A multigroup + or schema not there yet is made, and a value with no address is + stored as a schema stores it: a program as itself, a relation as its + tuples. [denials] are named [d], in + \denial of the home multigroup, or [m:d], in that of [m]. If the head moved meanwhile, or a multigroup does not + admit the state, nothing changes, and it fails. *) +val publish : + ?denials:(string * Protocols.Handle.t option) list -> + Protocols.Handle.t -> + branch:string -> + home:home -> + (string * Protocols.Handle.t option) list -> + (unit, Concepts.Condition.condition) result diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index 57bb79e..09aec90 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -116,6 +116,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* node = tuple_node tx relation in TupleSet.mem tx (Concepts.Tuple.hash tuple) node ) + method modes = + Ok + Concepts. + [ Mode.mode [] Cardinality.Finite; + Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1) + ] + method describe () = Ok (Protocols.Schematics.Relation description) method enumerate = enumerate connection relation @@ -134,6 +141,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> Result.map (fun description -> new substantial_relation connection relation description |> Protocols.Handle.make ) + let store tx description tuples = + let open Utilities.Result in + let* schematics = store_schema tx description in + let* _ = TupleSet.empty_under tx in + let* node = + TupleSet.with_batch tx (fun () -> + List.fold_left + (fun node tuple -> + let* node = node in + TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node ) + (Ok TupleSet.empty) tuples ) + in + let relation = {schematics; tuples= TupleSet.hash_of node} in + let* _ = SI.store_blob tx (encode relation) in + Ok relation + let instantiate connection ~schematics = let open Utilities.Result in let* relation = diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml new file mode 100644 index 0000000..c29f192 --- /dev/null +++ b/lib/protocols/Admission.ml @@ -0,0 +1,21 @@ +module Error = struct + open Concepts.Condition + + let not_admitting () = + condition "not-admitting" "A handle was expected to carry the admission protocol and did not" + empty +end + +type violations = (string * Concepts.Tuple.t) list + +class type implementation = object + method check : (violations, Concepts.Condition.condition) result +end + +type Handle.protocol += Admission of implementation +type t = implementation + +let make impl = Admission (impl :> implementation) +let from handle = Handle.into handle (function Admission impl -> Some impl | _ -> None) +let require handle = from handle |> Option.to_result ~none:(Error.not_admitting ()) +let check i = Handle.invoke i (fun o -> o#check) diff --git a/lib/protocols/Admission.mli b/lib/protocols/Admission.mli new file mode 100644 index 0000000..7f0c596 --- /dev/null +++ b/lib/protocols/Admission.mli @@ -0,0 +1,11 @@ +type t +type violations = (string * Concepts.Tuple.t) list + +class type implementation = object + method check : (violations, Concepts.Condition.condition) result +end + +val make : #implementation -> Handle.protocol +val from : Handle.t -> t Handle.interface option +val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result +val check : t Handle.interface -> (violations, Concepts.Condition.condition) result diff --git a/lib/protocols/Evaluator.ml b/lib/protocols/Evaluator.ml index 789fb9d..6a63431 100644 --- a/lib/protocols/Evaluator.ml +++ b/lib/protocols/Evaluator.ml @@ -1,5 +1,10 @@ +type kind = .. + class type implementation = object - method invoke : Handle.t -> (Handle.t, Concepts.Condition.condition) result + method parse : string -> (kind, Concepts.Condition.condition) result + + method eval : + kind -> Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result end type Handle.protocol += Evaluator of implementation @@ -8,4 +13,5 @@ type t = implementation let make impl = Evaluator (impl :> implementation) let from handle = Handle.into handle (function Evaluator impl -> Some impl | _ -> None) let require = Handle.require from -let invoke i program = Handle.invoke i (fun o -> o#invoke program) +let parse i source = Handle.invoke i (fun o -> o#parse source) +let eval i kind inputs ~within = Handle.invoke i (fun o -> o#eval kind inputs ~within) diff --git a/lib/protocols/Evaluator.mli b/lib/protocols/Evaluator.mli index 3d42b5c..934c5e3 100644 --- a/lib/protocols/Evaluator.mli +++ b/lib/protocols/Evaluator.mli @@ -1,10 +1,21 @@ type t +type kind = .. class type implementation = object - method invoke : Handle.t -> (Handle.t, Concepts.Condition.condition) result + method parse : string -> (kind, Concepts.Condition.condition) result + + method eval : + kind -> Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result end val make : #implementation -> Handle.protocol val from : Handle.t -> t Handle.interface option val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result -val invoke : t Handle.interface -> Handle.t -> (Handle.t, Concepts.Condition.condition) result +val parse : t Handle.interface -> string -> (kind, Concepts.Condition.condition) result + +val eval : + t Handle.interface -> + kind -> + Handle.t list -> + within:Handle.t -> + (Handle.t, Concepts.Condition.condition) result diff --git a/lib/protocols/Executable.ml b/lib/protocols/Executable.ml new file mode 100644 index 0000000..5dea52c --- /dev/null +++ b/lib/protocols/Executable.ml @@ -0,0 +1,12 @@ +class type implementation = object + method invoke : + Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result +end + +type Handle.protocol += Executable of implementation +type t = implementation + +let make impl = Executable (impl :> implementation) +let from handle = Handle.into handle (function Executable impl -> Some impl | _ -> None) +let require = Handle.require from +let invoke i inputs ~within = Handle.invoke i (fun o -> o#invoke inputs ~within) diff --git a/lib/protocols/Executable.mli b/lib/protocols/Executable.mli new file mode 100644 index 0000000..ccb63e1 --- /dev/null +++ b/lib/protocols/Executable.mli @@ -0,0 +1,19 @@ +type t + +(** [within] is the directory the program's paths resolve against: the + branch state a stored program was read through, or whatever part of + the tree a caller hands over. *) +class type implementation = object + method invoke : + Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result +end + +val make : #implementation -> Handle.protocol +val from : Handle.t -> t Handle.interface option +val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result + +val invoke : + t Handle.interface -> + Handle.t list -> + within:Handle.t -> + (Handle.t, Concepts.Condition.condition) result diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index dd923c6..0c5f3cc 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -91,4 +91,5 @@ let move handle = let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash let hash h = (object_of h)#hash let protocols h = (object_of h)#protocols +let releasing handle f = Fun.protect ~finally:(fun () -> release handle) f let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h) diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index 1c3b9d4..94734e4 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -19,6 +19,7 @@ val copy : t -> t option val move : t -> t val equal : t -> t -> bool val release : t -> unit +val releasing : t -> (unit -> 'a) -> 'a val hash : t -> Concepts.Hash.hash val protocols : t -> protocol list val to_string : t -> string diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml index 3962c9c..c1cdfee 100644 --- a/lib/protocols/Relation.ml +++ b/lib/protocols/Relation.ml @@ -8,6 +8,7 @@ end class type implementation = object method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result end type Handle.protocol += Relation of implementation @@ -17,3 +18,22 @@ let make impl = Relation (impl :> implementation) let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None) let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ()) let contains i tuple = Handle.invoke i (fun o -> o#contains tuple) +let modes i = Handle.invoke i (fun o -> o#modes) + +let heading relation = + let open Utilities.Result in + let* schematics = Handle.require Schematics.from relation in + let* description = Schematics.describe schematics in + match description with + | Schematics.Relation heading -> Ok heading + | _ -> Error (Error.not_a_relation ()) + +let read relation = + let open Utilities.Result in + let* heading = heading relation in + let* enumerable = Enumerable.require relation in + let* cursor = Enumerable.enumerate enumerable in + Handle.releasing cursor (fun () -> + let* scan = Cursor.require cursor in + let* tuples = Cursor.drain scan () in + Ok (heading, BatFingerTree.to_list tuples) ) diff --git a/lib/protocols/Relation.mli b/lib/protocols/Relation.mli index be11cc1..28dfdff 100644 --- a/lib/protocols/Relation.mli +++ b/lib/protocols/Relation.mli @@ -2,9 +2,19 @@ type t class type implementation = object method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result end val make : #implementation -> Handle.protocol val from : Handle.t -> t Handle.interface option val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result val contains : t Handle.interface -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result +val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition) result + +(** the heading a relation describes itself with. *) +val heading : Handle.t -> (Schematics.relation_description, Concepts.Condition.condition) result + +(** the heading and tuples of a relation, read whole. *) +val read : + Handle.t -> + (Schematics.relation_description * Concepts.Tuple.t list, Concepts.Condition.condition) result diff --git a/test/Helpers.ml b/test/Helpers.ml index f812a3a..ecd3985 100644 --- a/test/Helpers.ml +++ b/test/Helpers.ml @@ -18,6 +18,15 @@ let condition_as_failure = function let pp_value ppf v = Format.pp_print_string ppf (Concepts.Value.to_string v) let value = Alcotest.testable pp_value Concepts.Value.equal +(* the titles a relation of books holds, in order *) +let titles relation = + let open Utilities.Result in + let* _, tuples = Protocols.Relation.read relation in + Ok + ( tuples + |> List.map (fun tuple -> BatMap.String.find "title" tuple.Concepts.Tuple.attributes) + |> List.sort compare ) + module Storage = struct module type CONFIGURATOR = sig val configure : string -> Rnt.Concepts.Configuration.term @@ -40,21 +49,13 @@ module Storage = struct let relation conn attributes tuples = let open Utilities.Result in - let* value = - SI.with_transaction conn (fun tx -> - let* schematics = store_schema tx attributes in - let* _ = SR.TupleSet.empty_under tx in - let* node = - List.fold_left - (fun node tuple -> - let* node = node in - SR.TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node ) - (Ok SR.TupleSet.empty) tuples - in - let relation = {SR.schematics; tuples= SR.TupleSet.hash_of node} in - let* _ = SI.store_blob tx (SR.encode relation) in - Ok relation ) + let description = + BatMap.String.of_list + (List.map + (fun a -> a, {Protocols.Schematics.domain= "string"; provenance= []}) + attributes ) in + let* value = SI.with_transaction conn (fun tx -> SR.store tx description tuples) in SR.load conn value let with_connection f dir () = diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml index 693435b..2060ae6 100644 --- a/test/integration/Registration.ml +++ b/test/integration/Registration.ml @@ -6,49 +6,63 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = module I = Kernel.Initialization.Make (S) module B = Kernel.Branch.Make (S) module M = Kernel.Multigroup.Make (S) - module R = Kernel.SubstantialRelation.Make (S) module E = Kernel.EphemeralRelation.Make (S) - let book = Kernel.Path.("multigroup" @/ "library" @/ "relation" @/ "book" @/ this) - let shelf = Kernel.Path.("multigroup" @/ "library" @/ "relation" @/ "shelf" @/ this) + let book = + Kernel.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ "book" @/ this) + + let shelf = + Kernel.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ "shelf" @/ this) + + let stacks = Kernel.Path.("system" @/ "branch" @/ "stacks" @/ this) + + let titled title = + { Concepts.Tuple.type_= "book"; + attributes= + BatMap.String.of_list + ["title", Concepts.Value.String title; "author", Concepts.Value.String "Date"] } let run conn = let open Utilities.Result in begin let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in - let* multigroup = M.make conn in - let* schematics = H.SI.with_transaction conn (fun tx -> H.store_schema tx ["title"]) in - let* relation = R.instantiate conn ~schematics in - let* multigroup = - Kernel.Path.(assoc multigroup ("relation" @/ this) "book" (Some relation)) - in + let* relation = H.relation conn ["title"; "author"] [titled "SQL and Relational Theory"] in let* view = E.persist conn ~name:"shelf" ~evaluator:Evaluators.FOL.name ~code:Evaluators.FOL.(encode (Project (Base book, BatFingerTree.singleton "title"))) (BatMap.String.singleton "title" {Protocols.Schematics.domain= "string"; provenance= []}) in - let* multigroup = Kernel.Path.(assoc multigroup ("relation" @/ this) "shelf" (Some view)) in + let* multigroup = M.make conn in + let relations = Kernel.Path.("schema" @/ "default" @/ "relation" @/ this) in + let* multigroup = + Kernel.Path.assoc_all multigroup + [relations, "book", Some relation; relations, "shelf", Some view] + in let* branch = B.make conn in let* branch' = Kernel.Path.(assoc branch ("multigroup" @/ this) "library" (Some multigroup)) in - Kernel.Path.(update root ("branch" @/ this) "master" None (Some branch')) + Kernel.Path.(update root ("system" @/ "branch" @/ this) "stacks" None (Some branch')) end |> Helpers.condition_as_failure |> ignore; - let attributes = + let attributes, shelved = begin let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in - let* branch = Kernel.Path.(lookup root ("branch" @/ "master" @/ this)) in + let* branch = Kernel.Path.lookup root stacks in let* _ = Kernel.Path.lookup branch book in - let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in let* plan = Evaluators.FOL.(instantiate (Kernel.Path.lookup branch) (Base shelf)) in let* description = Evaluators.FOL.describe plan in - Ok (BatMap.String.keys description |> BatList.of_enum) + let* view = Kernel.Path.lookup branch shelf in + let* shelved = Helpers.titles view in + Ok (BatMap.String.keys description |> BatList.of_enum, shelved) end |> Helpers.condition_as_failure in - check (list string) "the stored view reads the book it was defined over" ["title"] attributes + check (list string) "the stored view reads the book it was defined over" ["title"] attributes; + check (list Helpers.value) "read through the branch, the stored view runs" + [Concepts.Value.String "SQL and Relational Theory"] + shelved let suite = ( "registration", diff --git a/test/test_rnt.ml b/test/test_rnt.ml index da8c008..c6fcfd5 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -5,6 +5,7 @@ let all_suites = @ Unit.Kernel.Merkle.suites () @ Unit.Kernel.SubstantialRelation.suites () @ Unit.Kernel.Session.suites () + @ Unit.Kernel.Branch.suites () @ Unit.Evaluators.FOL.suites () @ Integration.Registration.suites () diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml index 0a3dabc..a0789aa 100644 --- a/test/unit/evaluators/FOL.ml +++ b/test/unit/evaluators/FOL.ml @@ -23,6 +23,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = BatMap.String.of_list ["name", Concepts.Value.String name; "age", Concepts.Value.Integer age] } + (* a plan comes resolved, so it reads nothing through [within] *) + let nowhere = Kernel.Prototype.mixture [] + let drain result = let open Utilities.Result in let* enumerable = Protocols.Enumerable.require result in @@ -50,7 +53,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* evaluator = Option.to_result ~none:(missing "fol") found in let* evaluator = Protocols.Evaluator.require evaluator in let* result = - Rnt.Evaluators.FOL.(program (Base employee)) |> Protocols.Evaluator.invoke evaluator + Rnt.Evaluators.FOL.(program (Base employee)) + |> Protocols.Evaluator.invoke evaluator ~within:nowhere in drain result end @@ -74,7 +78,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in let* result = Rnt.Evaluators.FOL.(program (Project (Base employees, BatFingerTree.singleton "name"))) - |> Protocols.Evaluator.invoke evaluator + |> Protocols.Evaluator.invoke evaluator ~within:nowhere in drain result end @@ -100,7 +104,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name")) ) in let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator in + let* result = + Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator ~within:nowhere + in drain result end |> Helpers.condition_as_failure @@ -147,7 +153,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = instantiate (Kernel.Path.lookup root) (Base Kernel.Path.("view" @/ this)) ) in let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator in + let* result = + Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator ~within:nowhere + in drain result end |> Helpers.condition_as_failure @@ -158,6 +166,29 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = [["name", Concepts.Value.String "Alaric"]] (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)) + let run_a_stored_program_within conn = + let projected = + begin + let open Utilities.Result in + let* employees = H.relation conn ["name"; "age"] [employee "Alaric" 42] in + let* view = + store conn + Rnt.Evaluators.FOL.( + Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name") ) + in + let* root = namespace ["employee", employees] in + let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in + let* result = Protocols.Evaluator.invoke evaluator view ~within:root in + drain result + end + |> Helpers.condition_as_failure + in + check + (list (list (pair string Helpers.value))) + "the stored source read its relations where it was told to" + [["name", Concepts.Value.String "Alaric"]] + (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)) + let refuse_a_program_that_reads_itself conn = let expanded = begin @@ -197,7 +228,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in let* result = Rnt.Evaluators.FOL.(program (Project (Base source, BatFingerTree.singleton "value"))) - |> Protocols.Evaluator.invoke evaluator + |> Protocols.Evaluator.invoke evaluator ~within:nowhere in let* enumerable = Protocols.Enumerable.require result in let* cursor = Protocols.Enumerable.enumerate enumerable in @@ -220,6 +251,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (H.with_connection instantiate_a_program "fol-test"); test_case "expand-a-stored-program" `Quick (H.with_connection expand_a_stored_program "fol-test"); + test_case "run-a-stored-program-within" `Quick + (H.with_connection run_a_stored_program_within "fol-test"); test_case "refuse-a-program-that-reads-itself" `Quick (H.with_connection refuse_a_program_that_reads_itself "fol-test"); test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time ] ) diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml new file mode 100644 index 0000000..ebce298 --- /dev/null +++ b/test/unit/kernel/Branch.ml @@ -0,0 +1,167 @@ +open Alcotest +module K = Rnt.Kernel +module P = Rnt.Protocols +module C = Rnt.Concepts + +let ok = Helpers.condition_as_failure +let library = {K.Scope.multigroup= "library"; schema= "default"} +let master = K.Path.("system" @/ "branch" @/ "master" @/ this) +let under a b = K.Path.(of_list (to_list a @ to_list b)) +let shelf = K.Scope.path library "shelf" +let s v = C.Value.String v +let title = BatMap.String.singleton "title" {P.Schematics.domain= "string"; provenance= []} + +let books titles = + K.EphemeralRelation.literal title + (List.map + (fun t -> {C.Tuple.type_= "book"; attributes= BatMap.String.singleton "title" (s t)}) + titles ) + +let titles relation = ok (Helpers.titles relation) +let read root path = titles (ok (K.Path.lookup root path)) + +(* shelf is a stored FOL program reading book where it is stored *) +let shelved = + K.Source.view ~language:"fol" ~heading:title + ( Rnt.Evaluators.FOL.(encode (Base (K.Scope.path library "book"))) + |> C.Blob.bytes_of_blob + |> Bytes.to_string ) + +let publish root changes = ok (K.Scope.publish root ~branch:"master" ~home:library changes) + +let fresh books' = + let root = ok (Rnt.Scratch.root ()) in + publish root ["book", Some (books books'); "shelf", Some shelved]; + root + +let address handle = P.Addressable.address (Option.get (P.Addressable.from handle)) + +let reads_as_of_each_state () = + let root = fresh ["Codd"] in + publish root ["book", Some (books ["Codd"; "Date"])]; + check (list Helpers.value) "the head's view reads the books as they are" + [s "Codd"; s "Date"] + (read root (under master shelf)); + check (list Helpers.value) "the previous state's view reads them as they were" + [s "Codd"] + (read root (under master K.Path.("previous" @/ shelf))) + +let a_batch_is_one_successor () = + let root = fresh ["Codd"] in + let head = ok (K.Path.lookup root master) in + publish root ["book", Some (books ["Date"]); "loan", Some (books ["Codd"])]; + let next = ok (K.Path.lookup root master) in + let previous = ok (K.Path.lookup next K.Path.("previous" @/ this)) in + check bool "two changes, one state after the head" true + (C.Hash.hash_equals (address previous) (address head)); + let changed = + ok + (K.Path.diff + (ok (K.Path.lookup head K.Path.("multigroup" @/ this))) + (ok (K.Path.lookup next K.Path.("multigroup" @/ this))) ) + in + check + (list (list string)) + "the diff names what changed and nothing else" + [ ["library"; "schema"; "default"; "relation"; "book"]; + ["library"; "schema"; "default"; "relation"; "loan"] ] + (List.map K.Path.to_list changed) + +let unbinding_removes_a_relation () = + let root = fresh ["Codd"] in + publish root ["shelf", None]; + check bool "shelf is gone" true (Result.is_error (K.Path.lookup root (under master shelf))); + check (list Helpers.value) "book stays" + [s "Codd"] + (read root (under master (K.Scope.path library "book"))) + +let a_scope_reads_names_from_its_home () = + let root = fresh ["Codd"] in + K.Scope.publish root ~branch:"master" + ~home:{K.Scope.multigroup= "store"; schema= "default"} + ["stock", Some (books ["Date"]); "archive:old", Some (books ["Codd"])] + |> ok; + let scope = ok (K.Scope.of_root root ~branch:"master" library) in + let directory = Option.get (P.Directory.from scope) in + let found name = ok (P.Directory.find directory name) |> Option.map titles in + check + (option (list Helpers.value)) + "a bare name is the home schema's" + (Some [s "Codd"]) + (found "book"); + check + (option (list Helpers.value)) + "schema:name stays in the home multigroup" + (Some [s "Codd"]) + (found "default:book"); + check + (option (list Helpers.value)) + "multigroup:schema:name leaves it" + (Some [s "Date"]) + (found "store:default:stock"); + check (option (list Helpers.value)) "what is not there is not found" None (found "stock"); + check + (option (list Helpers.value)) + "four parts name an attribute, not a relation" None + (found "library:default:book:title"); + let catalog = ok (K.Scope.catalog (ok (K.Scope.require scope))) in + check (list string) "the catalog is every relation of the state" + ["library:default:book"; "library:default:shelf"; "store:archive:old"; "store:default:stock"] + (List.sort compare catalog); + check (option string) "a qualified attribute names the relation's own" (Some "title") + (K.Scope.attribute library "book" "library:default:book:title"); + check (option string) "but not another relation's" None + (K.Scope.attribute library "book" "shelf:title") + +(* A toy language answers a stored relation with its own name, and a run + with the source it was given. *) +let a_stored_relation_is_viewed_and_a_program_run () = + let root = fresh ["Codd"] in + let answer text = Ok (books [text]) in + let toy = + K.Source.evaluator ~language:"toy" + ~view:(fun ~within:_ ~name source -> answer (name ^ " of " ^ source)) + (fun ~within:_ source -> answer source) + in + let _ = ok (K.Initialization.mount root "toys") in + ok (K.Source.register root ~scope:"toys" ~language:"toy" toy); + publish root ["named", Some (K.Source.view ~language:"toys:toy" ~heading:title "this")]; + check (list Helpers.value) "read from the branch, the view is asked for it by name" + [s "named of this"] + (read root (under master (K.Scope.path library "named"))); + check (list Helpers.value) "run, the program is just run" + [s "that"] + (titles (ok (K.Source.run root ~language:"toys:toy" ~within:root "that"))); + check bool "an unqualified name is the system's" true + (Result.is_error (K.Source.run root ~language:"toy" ~within:root "that")) + +(* shelf, stored as a denial, says no book may be shelved *) +let a_head_moves_only_to_a_valid_state () = + let root = fresh [] in + publish root ["denial:no-books", Some shelved]; + let head = ok (K.Path.lookup root master) in + let proposed = + ok + (K.Path.assoc_all head + [ ( K.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ this), + "book", + Some (books ["Codd"]) ) ] ) + in + check bool "a state with a book is judged invalid without landing" true + (Result.is_error (K.Denial.check proposed)); + check bool "publishing it is refused" true + (Result.is_error + (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Codd"])]) ); + check bool "and the head stays" true + (C.Hash.hash_equals (address head) (address (ok (K.Path.lookup root master)))) + +let suites () = + [ ( "kernel/branch", + [ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state; + test_case "a-batch-is-one-successor" `Quick a_batch_is_one_successor; + test_case "unbinding-removes-a-relation" `Quick unbinding_removes_a_relation; + test_case "a-scope-reads-names-from-its-home" `Quick a_scope_reads_names_from_its_home; + test_case "a-stored-relation-is-viewed-and-a-program-run" `Quick + a_stored_relation_is_viewed_and_a_program_run; + test_case "a-head-moves-only-to-a-valid-state" `Quick a_head_moves_only_to_a_valid_state ] ) + ] diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml index d7ffa92..7f113ef 100644 --- a/test/unit/kernel/EphemeralRelation.ml +++ b/test/unit/kernel/EphemeralRelation.ml @@ -97,9 +97,9 @@ let releasing_releases_its_inputs () = let released = ref false in let input = object - inherit Rnt.Kernel.Lifecycle.null - inherit Rnt.Kernel.Identity.of_id - method! release = released := true + method reference = true + method release = released := true + method hash = Concepts.Hash.hash_of_int 0 method to_string = "input" method protocols : Protocols.Handle.protocol list = [] end diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml index 9d0dc6e..5c8d761 100644 --- a/test/unit/kernel/Merkle.ml +++ b/test/unit/kernel/Merkle.ml @@ -126,12 +126,42 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (* let determinism _conn = *) (* () *) + (* Enough keys for the tree to grow trunks, so removal reaches through + them and empties whole leaves. *) + let removal conn = + let kept, gone, keys, emptied = + begin + let open Utilities.Result in + let* tx = S.start conn in + let key i = Printf.sprintf "k%03d" i in + let all = List.init 300 key in + let* full = List.fold_left (fun node k -> fmap (T.insert tx k k) node) (Ok T.empty) all in + let evens = List.filteri (fun i _ -> i mod 2 = 0) all in + let* half = List.fold_left (fun node k -> fmap (T.remove tx k) node) (Ok full) evens in + let* kept = T.lookup tx (key 1) half in + let* gone = T.lookup tx (key 2) half in + let* keys = T.keys tx half in + let* none = List.fold_left (fun node k -> fmap (T.remove tx k) node) (Ok half) all in + let* () = S.abort tx in + Ok (kept, gone, BatFingerTree.to_list keys, T.hash_of none) + end + |> Helpers.condition_as_failure + in + check (option string) "a key not removed stays" (Some "k001") kept; + check (option string) "a removed key is gone" None gone; + check (list string) "exactly the odd keys remain" + (List.init 150 (fun i -> Printf.sprintf "k%03d" ((2 * i) + 1))) + keys; + check bool "removing every key leaves the empty tree" true + (Concepts.Hash.hash_equals emptied (T.hash_of T.empty)) + let suite = ( "kernel/merkle", [ test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test"); test_case "batching" `Quick (H.with_connection batching "merkle-test"); test_case "persistence" `Quick (H.with_connection persistence "merkle-test"); - test_case "iteration" `Quick (H.with_connection iteration "merkle-test") ] ) + test_case "iteration" `Quick (H.with_connection iteration "merkle-test"); + test_case "removal" `Quick (H.with_connection removal "merkle-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) diff --git a/test/unit/kernel/Session.ml b/test/unit/kernel/Session.ml index 3ae549f..79ad5a2 100644 --- a/test/unit/kernel/Session.ml +++ b/test/unit/kernel/Session.ml @@ -22,21 +22,25 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let open Rnt.Kernel.Path in let* root = I.initialize conn in let* branch = B.make conn in - let* _ = update root ("branch" @/ this) "master" None (Some branch) in + let* _ = update root ("system" @/ "branch" @/ this) "client" None (Some branch) in let* tip = address branch in let session = Session.make conn {Protocols.Session.snapshot= tip} in - let* _ = update root ("session" @/ this) "client" None (Protocols.Handle.copy session) in - let library = "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this in + let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in + let library = + "system" @/ "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this + in let before = finds root library in let* multigroup = M.make conn in let* branch' = assoc branch ("multigroup" @/ this) "library" (Some multigroup) in - let* _ = update root ("branch" @/ this) "master" (Some branch) (Some branch') in + let* _ = update root ("system" @/ "branch" @/ this) "client" (Some branch) (Some branch') in let unchanged = finds root library in let* tip' = address branch' in let* interface = Protocols.Handle.require Protocols.Session.from session in Protocols.Session.pin interface {Protocols.Session.snapshot= tip'}; let after = finds root library in - let* pinned = lookup root ("session" @/ "client" @/ "branch" @/ this) |> fmap address in + let* pinned = + lookup root ("system" @/ "session" @/ "client" @/ "branch" @/ this) |> fmap address + in let refused = assoc session ("branch" @/ "multigroup" @/ this) "other" (Some multigroup) |> Result.is_error @@ -51,9 +55,32 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = check bool "the session reconstructs the pinned branch" true pinned; check bool "the session refuses derivation through it" true refused + let single_handle conn = + let refused, reacquired = + begin + let open Utilities.Result in + let open Rnt.Kernel.Path in + let* root = I.initialize conn in + let* branch = B.make conn in + let* tip = address branch in + let session = Session.make conn {Protocols.Session.snapshot= tip} in + let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in + let client = "system" @/ "session" @/ "client" @/ this in + let* _ = lookup root ("system" @/ "session" @/ "client" @/ "branch" @/ this) in + let* held = lookup root client in + let refused = finds root client in + Protocols.Handle.release held; + Ok (refused, finds root client) + end + |> Helpers.condition_as_failure + in + check bool "a second handle to the session is refused" false refused; + check bool "releasing the handle frees the session" true reacquired + let suite = ( "kernel/session", - [test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test")] ) + [ test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test"); + test_case "single-handle" `Quick (H.with_connection single_handle "session-single-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) |