diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/runtime/Context.ml | 68 | ||||
| -rw-r--r-- | lib/runtime/Context.mli | 9 |
2 files changed, 25 insertions, 52 deletions
diff --git a/lib/runtime/Context.ml b/lib/runtime/Context.ml index 10422e4..000f5d6 100644 --- a/lib/runtime/Context.ml +++ b/lib/runtime/Context.ml @@ -1,60 +1,30 @@ module Error = struct open Concepts.Condition - let budget_exhausted ~requested ~remaining = - condition "budget-exhausted" "An evaluation asked for more budget than it had left" - ("requested" |=| Concepts.Value.Integer requested - & "remaining" |=| Concepts.Value.Integer remaining) - let not_a_directory segment = condition "not-a-directory" "A path segment named an object with no Directory protocol" ("segment" |=| Concepts.Value.String segment) end -type budget = int Atomic.t - -let charge_budget budget n = +let resolve { Protocols.Context.root; _ } name = let open Utilities.Result in - let* _ = - Utilities.Atomic.mswap budget (fun remaining -> - if remaining >= n then Ok (remaining - n) - else Error (Error.budget_exhausted ~requested:n ~remaining) ) + let rec walk handle = function + | [] -> Ok (Protocols.Handle.copy handle) + | segment :: rest -> + let* directory = + Protocols.Directory.from handle + |> Option.to_result ~none:(Error.not_a_directory segment) + in + let* found = Protocols.Directory.find directory segment in + match found with + | None -> Ok None + | Some child -> + Fun.protect ~finally:(fun () -> Protocols.Handle.release child) + (fun () -> walk child rest) in - Ok () - -class context ~root ~budget ~cancelled = - object (self) - val root : Protocols.Handle.t = root - val budget : budget = budget - val cancelled : unit -> bool = cancelled - - method resolve (name : string) : - (Protocols.Handle.t option, Concepts.Condition.condition) result = - let open Utilities.Result in - let rec walk handle = function - | [] -> Ok (Protocols.Handle.copy handle) - | segment :: rest -> - let* directory = Protocols.Directory.from handle - |> Option.to_result ~none:(Error.not_a_directory segment) - in - let* found = Protocols.Directory.find directory segment in - match found with - | None -> Ok None - | Some child -> - Fun.protect ~finally:(fun () -> Protocols.Handle.release child) - (fun () -> walk child rest) - in - String.split_on_char '/' name |> List.filter (fun segment -> segment <> "") |> walk root - - method cancelled = cancelled () - method charge n = charge_budget budget n - method nest ?authority:(_ : string BatSet.t option) () = - (new context ~root ~budget ~cancelled :> Protocols.Context.implementation) - - initializer ignore self - end - -let over ~root ?(budget = max_int) ?(cancelled = fun () -> false) () = - Protocols.Context.make (new context ~root ~budget:(Atomic.make budget) ~cancelled) + String.split_on_char '/' name |> List.filter (fun segment -> segment <> "") |> walk root -let remaining (_ : Protocols.Context.t) : int option = failwith "not implemented" +let over ~snapshot ~root ?(cancelled = fun () -> false) () = + { Protocols.Context.snapshot + ; root + ; status = (fun () -> if cancelled () then `Cancelled else `Live) } diff --git a/lib/runtime/Context.mli b/lib/runtime/Context.mli index 31ef194..6e7ab2f 100644 --- a/lib/runtime/Context.mli +++ b/lib/runtime/Context.mli @@ -1,8 +1,11 @@ +val resolve : + Protocols.Context.t -> + string -> + (Protocols.Handle.t option, Concepts.Condition.condition) result + val over : + snapshot:Concepts.Hash.hash -> root:Protocols.Handle.t -> - ?budget:int -> ?cancelled:(unit -> bool) -> unit -> Protocols.Context.t - -val remaining : Protocols.Context.t -> int option |
