lib/runtime/Context.ml


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

module Error = struct
  open Concepts.Condition

  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

let resolve { Protocols.Context.root; _ } name =
  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

let over ~snapshot ~root ?(cancelled = fun () -> false) () =
  { Protocols.Context.snapshot
  ; root
  ; status = (fun () -> if cancelled () then `Cancelled else `Live) }