Source file fs_impl.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda.jp>                 *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Separated from fs.mli so that some internal functions can be used
   in fs_tree.ml *)

open Result_lwt.Syntax
open Result_lwt.Infix
open Fs_types

module Name = Name

type name = Name.t

module Path = Path

module FsError = FsError

type cursor =
  { cur : Cursor.t;
    rev_path : Name.t list; (* position of the cur *)
    enc : Fs_nameenc.t
  }

type error = FsError.t

type view = Node_type.view

type raw_cursor = Cursor.t

type hash = Hash.Prefix.t
(* Hash.Prefix.t since Extender is never exposed *)

let make cur enc path = { cur; rev_path= List.rev path; enc }

let empty context enc = make (Cursor.empty context) enc []

let get_raw_cursor c = c.cur

let get_view c =
  let cur, v = Cursor.view c.cur in
  { c with cur }, v

let context c = Cursor.context c.cur

let index c = Cursor.index @@ get_raw_cursor c

let forget_info c = { c with cur = Cursor.forget_info c.cur }

let top_cursor c = make (Cursor.go_top c.cur) c.enc []

let compute_hash c =
  let cur, h = Cursor.compute_hash c.cur in
  { c with cur }, h

let write_top_cursor { cur; enc; _ } =
  let cur = Cursor.go_top cur in
  let+? cur, idx, hp = Cursor.Cursor_storage.write_top_cursor cur in
  ({ cur; rev_path= []; enc }, (idx, hp))

let may_forget c =
  match Cursor.may_forget c.cur with
  | Some cur -> { c with cur }
  | None -> c

(* split the last element of the list *)
let split xs =
  let rec f st = function
    | [] -> assert false
    | [x] -> List.rev st, x
    | x::xs -> f (x::st) xs
  in
  f [] xs

module Op = struct
  module Monad = Monad.Make1(struct
      type 'a t = cursor -> (cursor * 'a, Error.t) result

      let return a c = Ok (c, a)

      let bind (aop : 'a t) (f : 'a -> 'b t) : 'b t =
        fun c ->
        match aop c with
        | Error e ->
            Error e
        | Ok (c, a) ->
            f a c
    end)

  include Monad

  let lift_result = fun r c -> Result.map (fun x -> (c, x)) r

  let check_cursor_invariant ({ cur; rev_path; enc } as c) =
    let p = Cursor.path_of_cursor cur in
    match Option.mapM (Fs_nameenc.of_segment enc) p with
    | None -> assert false
    | Some path ->
        assert (path = List.rev rev_path);
        Ok (c, ())

  let fail e : 'a t = fun _ -> FsError.error e
  let raw_cursor : Cursor.t t = fun c -> Ok (c, c.cur)
  let path : Path.t t = fun c -> Ok (c, List.rev c.rev_path)
  let view : view t = fun c -> Ok (get_view c)

  let chdir_parent c =
    (* if [c] is at the root, NOP *)
    match c.rev_path with
    | [] -> Ok (c, ())
    | path::rev_path ->
        let cur, v = Cursor.view c.cur in
        (* remove the directory if it is empty *)
        let remove_it =
          match v with
          | Bud (None, _, _) -> true
          | _ -> false
        in
        Cursor.go_up_to_bud cur >>? fun cur ->
        if remove_it then
          Cursor.delete' cur (Fs_nameenc.to_segment c.enc path) >>? fun cur ->
          Ok ({ c with cur; rev_path }, ())
        else
          Ok ({ c with cur; rev_path }, ())

  let rec chdir_root c =
    match c.rev_path with
    | [] -> Ok (c, ())
    | _ ->
        chdir_parent c >>? fun (c, ()) ->
        chdir_root c

  (* If [dig=true], creates subdirectories if necessary. *)
  let chdir ?(dig=false) path0 : unit t = fun c ->
    let rec seek path ({ cur; rev_path; _ } as c) =
      match path with
      | [] ->
          let _cur, v = Cursor.view cur in
          begin match v with
            | Bud _ -> Ok (c, ())
            | Leaf _ -> FsError.error (Is_file ("chdir", List.rev rev_path))
            | _ -> Format.eprintf "chdir path0=%a cwd=%a %a@." Path.pp path0 Path.pp (List.rev rev_path) Node_type.pp (View v); assert false
          end
      | p :: path ->
          let cur, v = Cursor.view cur in
          match v with
          | Bud _ ->
              let seg = Fs_nameenc.to_segment c.enc p in
              Cursor.access_gen cur seg
              >>? (function
                  | Reached (_cur, Leaf _) ->
                      FsError.error (Is_file ("chdir", List.rev rev_path))
                  | Reached (cur, Bud _) ->
                      seek path { c with cur; rev_path= p::rev_path }
                  | Empty_bud | Middle_of_extender _ when dig ->
                      let cur = Result.from_Ok @@ Cursor.subtree_or_create cur seg in
                      seek path { c with cur; rev_path= p::rev_path }
                  | Empty_bud | Middle_of_extender _ ->
                      FsError.error (No_such_file_or_directory ("chdir", List.rev (p::rev_path)))
                  | Collide _ | Reached _ ->
                      assert false (* it indicates fs inconsistency *)
                  (* error_fs (No_such_file_or_directory ("seek", path0)) *)
                  | HashOnly _ -> assert false (* XXX *)
                )
          | Leaf _ ->
              FsError.error (Is_file ("chdir", List.rev rev_path))
          | Internal _ | Extender _ ->
              assert false (* it indicates fs inconsistency *)
              (* error_fs (No_such_file_or_directory ("seek", path0)) *)
    in
    seek path0 c

  (* Functions in Loose module does not preserve the cwd.
     Not good to write apps since it is hard to predict where the cwd is.
  *)
  module Loose = struct
    (* Access the path *)
    let seek path0 : (cursor * view) t = fun c ->
      let rec seek path { cur; rev_path; enc } =
        match path with
        | [] ->
            let (cur, v) = Cursor.view cur in
            begin match v with
              | Leaf _ | Bud _ ->
                  let c = { c with cur; rev_path } in
                  Ok (c, (c, v))
              | Internal _ | Extender _ ->
                  assert false (* it indicates fs inconsistency *)
                  (* error_fs (No_such_file_or_directory ("seek", path0)) *)
            end
        | p :: path ->
            let seg = Fs_nameenc.to_segment enc p in
            let cur, v = Cursor.view cur in
            match v with
            | Bud _ ->
                Cursor.access_gen cur seg
                >>? (function
                    | Reached (cur, (Bud _ | Leaf _)) ->
                        seek path { c with cur; rev_path= p::rev_path }
                    | Empty_bud | Middle_of_extender _ ->
                        FsError.error (No_such_file_or_directory ("seek", path0))
                    | Collide _ | Reached _ ->
                        assert false (* it indicates fs inconsistency *)
                    (* error_fs (No_such_file_or_directory ("seek", path0)) *)
                    | HashOnly _ -> assert false (* XXX *)
                  )
            | Leaf _ ->
                FsError.error (Is_file ("seek", List.rev rev_path))
            | Internal _ | Extender _ ->
                assert false (* it indicates fs inconsistency *)
                (* error_fs (No_such_file_or_directory ("seek", path0)) *)
      in
      seek path0 c

    (* Seeking a directory.  Stops seeking when it finds no directory
       and returns the path postfix not found.
    *)
    let seek' path0 : Path.t t = fun c ->
      let rec seek path ({ cur; rev_path; enc } as c) =
        match path with
        | [] -> Ok (c, [])
        | p :: path ->
            let cur, v = Cursor.view cur in
            match v with
            | Bud _ ->
                let seg = Fs_nameenc.to_segment enc p in
                Cursor.access_gen cur seg
                >>? (function
                    | Reached (cur, (Bud _ | Leaf _)) ->
                        seek path { c with cur; rev_path= p::rev_path }
                    | Empty_bud | Middle_of_extender _ ->
                        Ok (c, (p::path))
                    | Collide _ | Reached _ ->
                        assert false (* it indicates fs inconsistency *)
                    (* error_fs (No_such_file_or_directory ("seek", path0)) *)
                    | HashOnly _ -> assert false (* XXX *)
                  )
            | Leaf _ ->
                FsError.error (Is_file ("seek'", List.rev rev_path))
            | Internal _ | Extender _ ->
                assert false (* it indicates fs inconsistency *)
                (* error_fs (No_such_file_or_directory ("seek", path0)) *)
      in
      seek path0 c

    let get = seek

    let cat path c =
      seek path c >>? function
      | (c, (_, Leaf (v, _, _))) -> Ok (c, v)
      | (_, (_, Bud _)) -> FsError.error (Is_directory ("cat", path))
      | (_, (_, (Internal _ | Extender _))) -> assert false

    let write path0 value c =
      let d,n = split path0 in
      chdir ~dig:true d c >>? fun (c, ()) ->
      view c >>? fun (c,v) ->
      match v with
      | Bud _ ->
          Cursor.upsert c.cur (Fs_nameenc.to_segment c.enc n) value
          >|? fun cur -> { c with cur }, ()
      | Leaf _ | Internal _ | Extender _ -> assert false

    let unlink path check c =
      let d,n = split path in
      seek' d c >>? fun (c, p) ->
      match p with
      | _::_ ->
          (* target does not exist *)
          Ok (c, false)
      | [] ->
          let seg = Fs_nameenc.to_segment c.enc n in
          Cursor.access_gen c.cur seg
          >>? function
          | Empty_bud | Middle_of_extender _ ->
              (* target does not exist *)
              Ok (c, false)
          | Collide _ | Reached (_, (Extender _ | Internal _)) ->
              assert false (* it indicates fs inconsistency *)
          | HashOnly _ ->
              (* error_fs (No_such_file_or_directory ("seek", path0)) *)
              assert false (* XXX *)
          | Reached (_cur, (Bud _ | Leaf _ as v)) ->
              let k = match v with
                | Bud _ -> `Bud v
                | Leaf _ -> `Leaf v
                | Internal _ | Extender _ -> assert false
              in
              check k >>? fun () ->
              Cursor.delete c.cur seg
              >>? fun cur ->
              let c = { c with cur } in
              let rec loop c =
                match c.rev_path with
                | [] -> Ok (c, true) (* allow Bud (None) at the root *)
                | n::rev_path ->
                    view c >>? fun (c,v) ->
                    match v with
                    | Bud (Some _, _, _) -> Ok (c, true)
                    | Bud (None, _, _) ->
                        Cursor.go_up_to_bud c.cur >>? fun cur ->
                        Cursor.delete cur (Fs_nameenc.to_segment c.enc n) >>? fun cur ->
                        loop { c with cur; rev_path }
                    | Leaf _ | Internal _ | Extender _ -> assert false
              in
              loop c

    let set path c' c =
      if c.enc != c'.enc then
        FsError.error (Other ("set", "Conflicting name encoders"))
      else
        view c' >>? fun (_, v) ->
        match v with
        | Bud (None, _, _) ->
            unlink path (fun _ -> Ok ()) c >|? fun (c,_) -> (c, ())
        | Bud _ | Leaf _ ->
            let d,n = split path in
            seek' d c >>? fun (c, p) ->
            Deep.alter c.cur (Fs_nameenc.to_segments c.enc (p@[n])) (fun _ -> Ok (View v))
            >|? fun cur -> ({c with cur= cur}, ())
        | Internal _ | Extender _ -> assert false

    let rm ?(recursive=false) ?(ignore_error=false) path c =
      let check = function
        | `Bud _ when not recursive -> FsError.error (Is_directory ("rm", path))
        | `Bud _ | `Leaf _ -> Ok ()
      in
      match unlink path check c with
      | Ok (c, true) -> Ok (c,true)
      | Ok (c, false) when ignore_error -> Ok (c,false)
      | Ok (_, false) -> FsError.error (No_such_file_or_directory ("rm", path))
      | Error _ when ignore_error -> Ok (c,false)
      | Error _ as e -> e

    let rmdir ?(ignore_error=false) path c =
      let check = function
        | `Leaf _ -> FsError.error (Is_file ("rmdir", path))
        | `Bud _ -> Ok ()
      in
      match unlink path check c with
      | Ok (c, true) -> Ok (c,true)
      | Ok (c, false) when ignore_error -> Ok (c,false)
      | Ok (_, false) -> FsError.error (No_such_file_or_directory ("rmdir", path))
      | Error _ when ignore_error -> Ok (c,false)
      | Error _ as e -> e
  end

  (* Perform [f] then recover the original place of the current cursor.
     Unspecified if [chdir_parent] or [chdir_root] are called inside [f].
  *)
  let with_pushd f c =
    let path0 = List.rev c.rev_path in
    f c >>? fun (c,res) ->
    match Path.is_prefix_of path0 (List.rev c.rev_path) with
    | None -> assert false
    | Some p ->
        let rec loop c = function
          | 0 -> Ok (c, res)
          | n -> chdir_parent c >>? fun (c, ()) -> loop c (n-1)
        in
        loop c @@ List.length p

  let get path = with_pushd @@ Loose.get path

  let cat path = with_pushd @@ Loose.cat path

  let write path value = with_pushd @@ Loose.write path value

  let unlink path check = with_pushd @@ Loose.unlink path check

  let set path c' = with_pushd @@ Loose.set path c'

  let copy from to_ : unit t = fun c ->
    get from c >>? fun (c, (c_from, _v_from)) ->
    set to_ c_from c

  let rm ?recursive ?ignore_error path =
    with_pushd @@ Loose.rm ?recursive ?ignore_error path

  let rmdir ?ignore_error path =
    with_pushd @@ Loose.rmdir ?ignore_error path

  let do_then f (g : 'a t) = fun c -> f c; g c

  let run c op = op c

  let compute_hash ({ cur; _ } as c) =
    let cur, h = Cursor.compute_hash cur in
    let hp = fst h in
    assert (snd h = "");
    Ok ({c with cur}, hp)

  (* XXX Things almost always not forgotten, since cur points a Bud *)
  let may_forget ({ cur; _ } as c) =
    let cur =
      match Cursor.may_forget cur with
      | Some cur -> cur
      | None -> cur
    in
    Ok ({c with cur}, ())
end

module Op_lwt = struct
  module Monad = Monad.Make1(struct
      type 'a t = cursor -> (cursor * 'a, Error.t) result Lwt.t

      let return a c = Lwt.return_ok (c, a)

      let bind (aop : 'a t) (f : 'a -> 'b t) : 'b t =
        fun c ->
        Lwt.bind (aop c) (function
            | Error _ as e -> Lwt.return e
            | Ok (c, a) -> f a c)
    end)

  include Monad

  let lift : 'a Op.t -> 'a t = fun op c -> Lwt.return @@ op c
  let lift_op = lift
  let lift_lwt : 'a Lwt.t -> 'a t = fun l c -> Lwt.map (fun x -> Ok (c, x)) l
  let lift_result : ('a, Error.t) Result.t -> 'a t = fun r c -> Lwt.return @@ Result.map (fun x -> (c, x)) r
  let lift_result_lwt : ('a, Error.t) Result_lwt.t -> 'a t = fun rl c -> Result_lwt.map (fun x -> (c, x)) rl

  let fail e = lift (Op.fail e)
  let raw_cursor = lift Op.raw_cursor
  let chdir_parent = lift Op.chdir_parent
  let chdir_root = lift Op.chdir_root
  let chdir ?dig path0 = lift (Op.chdir ?dig path0)
  let path = lift Op.path
  let get path = lift (Op.get path)
  let set path c = lift (Op.set path c)
  let copy from to_ = lift (Op.copy from to_)
  let cat path = lift (Op.cat path)
  let write path value = lift (Op.write path value)
  let rm ?recursive ?ignore_error path = lift (Op.rm ?recursive ?ignore_error path)
  let rmdir ?ignore_error path = lift (Op.rmdir ?ignore_error path)
  let compute_hash = lift Op.compute_hash
  let may_forget = lift Op.may_forget
  let do_then f g c = f c;g c

  let with_pushd_lwt f c =
    let path0 = List.rev c.rev_path in
    f c >>=? fun (c,res) ->
    match Path.is_prefix_of path0 (List.rev c.rev_path) with
    | None -> assert false
    | Some p ->
        let rec loop c = function
          | 0 -> Lwt.return_ok (c, res)
          | n ->
              match Op.chdir_parent c with
              | Error e -> Lwt.return_error e
              | Ok (c, ()) -> loop c (n-1)
        in
        loop c @@ List.length p

  module Segs = Segment.Segs

(*
         'a * job_stack * Plebeia__Segment.Segs.t * raw_cursor ->
         ('a ->
          Plebeia__Segment.Segs.t ->
          raw_cursor ->
          ([< `Continue | `Exit | `Up ] * 'a, Plebeia__Error.t) result Lwt.t) ->
         ('a * job_stack * Segs.t * raw_cursor, Plebeia__Error.t) result Lwt.t
*)

  (* From here, functions preserve the current position of the cursor *)

  type job_stack = [ `Exit | `Right of job_stack | `Up of Segs.t * job_stack ]

  type 'acc traverse_stat =
    { acc : 'acc
    ; dests : job_stack
    ; segs : Segs.t
    ; c :raw_cursor
    }

  type 'acc folder =
    'acc -> Segs.t -> raw_cursor -> ([`Continue | `Exit | `Up] * 'acc, Error.t) result Lwt.t

  (* The result is unspecified or unpredictable if the tree is modified
     during the traverse *)
  let traverse { acc; dests; segs; c } (f : 'acc folder)
    : ('acc traverse_stat, Error.t) result Lwt.t =
    let rec next {acc; dests; segs; c} = match dests with
      | `Exit -> Ok {acc; dests= `Exit; segs; c}
      | `Up (segs, dests) ->
          Cursor.go_up c >>? fun c ->
          next {acc; dests; segs; c}
      | `Right dests ->
          Cursor.go_side Right c >|? fun c ->
          {acc; dests= `Up (segs, dests); segs= Segs.add_side segs Right; c}
    in
    let rec exit {acc; dests; segs; c} = match dests with
      | `Exit -> Ok {acc; dests= `Exit; segs; c}
      | `Up (segs, dests) ->
          Cursor.go_up c >>? fun c -> exit {acc; dests; segs; c}
      | `Right dests -> exit {acc; dests; segs; c}
    in
    let c, v = Cursor.view c in
    Lwt.bind (f acc segs c) @@ function
    | Error _ as e -> Lwt.return e
    | Ok (`Exit, acc) -> Lwt.return @@ exit {acc; dests; segs; c}
    | Ok (`Up, acc) -> Lwt.return @@ next {acc; dests; segs; c}
    | Ok (`Continue, acc) ->
        match v with
        | Leaf _ | Bud (None, _, _) ->
            Lwt.return @@ next {acc; dests; segs; c}
        | Bud (Some _, _, _) ->
            Lwt.return begin
              Cursor.go_below_bud c >>? function
              | None -> assert false
              | Some c -> Ok {acc; dests= `Up (segs, dests); segs= Segs.push_bud segs; c}
            end
        | Internal (_, _, _, _) ->
            Lwt.return begin
              Cursor.go_side Left c >>? fun c ->
              Ok {acc; dests= `Up (segs, `Right dests); segs= Segs.add_side segs Left; c}
            end
        | Extender (seg, _, _, _) ->
            Lwt.return begin
              Cursor.go_down_extender c >>? fun c ->
              Ok {acc; dests= `Up (segs, dests); segs= Segs.append_seg segs seg; c}
            end

  let raw_fold (init : 'acc) (c : raw_cursor) (f : 'acc folder) =
    let rec loop x =
      Lwt.bind (traverse x f) @@ function
      | Error e -> Lwt.return_error e
      | Ok {acc; dests= `Exit; segs=_; c} -> Lwt.return_ok (c, acc)
      | Ok x -> Lwt.(pause () >>= fun () -> loop x)
    in
    loop {acc=init; dests=`Exit; segs= Segs.empty; c}

  let fold_here
      (init : 'acc)
      (f : 'acc -> Path.t -> cursor -> ([ `Continue | `Exit | `Up ] * 'acc, Error.t) result Lwt.t)
      { cur; rev_path; enc } =
    Result_lwt.map (fun (c,a) -> { cur=c; rev_path; enc }, a)
      (raw_fold init cur (fun acc segs c ->
           let c, v = Cursor.view c in
           match v with
           | Internal _ | Extender _ ->
               Lwt.return @@ Ok (`Continue, acc)
           | Leaf _ | Bud _ ->
               let segs = Segs.to_segments segs in
               (* XXX path decoding each time... *)
               (* XXX error report *)
               let path = Utils.from_Some @@ Fs_nameenc.of_segments enc segs in
               f acc path { cur=c; rev_path= List.rev_append path rev_path; enc }))

  let fold'_here ?depth
      (init : 'acc)
      (f : 'acc -> Path.t -> cursor -> ('acc, Error.t) result Lwt.t) : 'acc t = fun c ->
    let check =
      match depth with
      | None -> fun _ -> true, true
      | Some (`Eq n) -> fun x -> x < n, x = n
      | Some (`Le n) -> fun x -> x < n, x <= n
      | Some (`Lt n) -> fun x -> x < n-1, x < n
      | Some (`Ge n) -> fun x -> true, x >= n
      | Some (`Gt n) -> fun x -> true, x > n
    in
    let f = fun acc path c ->
      match Cursor.view c.cur with
      | _, (Internal _ | Extender _) -> assert false
      | _, (Leaf _ | Bud _) ->
          let depth = Path.length path in
          let deeper, callf = check depth in
          let command = if deeper then `Continue else `Up in
          Result_lwt.map (fun acc -> (command, acc))
            (if callf then f acc path c else Lwt.return (Ok acc))
    in
    fold_here init f c

  let at_dir name path0 (f : _ t) : _ t = fun c ->
    with_pushd_lwt (fun c ->
        match Op.Loose.seek path0 c with
        | Error _ as e -> Lwt.return e
        | Ok (c, (_c, v)) ->
            match v with
            | Leaf _ ->
                Lwt.return @@ FsError.error (Is_file (name, path0))
            | Bud _ -> f c
            | Internal _ | Extender _ -> assert false) c

  let fold init path0 f : _ t = at_dir "fold" path0 (fold_here init f)

  let fold' ?depth init path0 f = at_dir "fold" path0 (fold'_here ?depth init f)

  (* We assume that Buds and directories correspond with each other *)
  let ls : Path.t -> (Name.t * cursor) list t = fun path0 c ->
    let f a path tree =
      match path with
      | [] | _::_::_ -> assert false
      | [name] -> Lwt.return @@ Ok ((name, tree) :: a)
    in
    (* XXX we can traverse in the opposite order *)
    Result_lwt.map (fun (c,xs) -> c, List.rev xs)
    @@ fold' ~depth:(`Eq 1) [] path0 f c

  let count : Path.t -> int option t = fun path0 ->
    at_dir "count" path0 @@ fun c ->
    match Cursor.count c.cur with
    | None -> Lwt.return_ok (c, None)
    | Some (cnt, cur) -> Lwt.return_ok ({ c with cur }, Some cnt)

  (* The result is unspecified or unpredictable if the tree is modified
     during the traverse *)
    (*
               (offset, length)
                      o (has cnt)    Skip offset+length-1 < 0 || cnt < offset

               (offset, length)
               [offset, offset+length-1]
                      o (has cnt)    Skip offset+length-1 < 0 || cnt < offset
                     / \
         (has cntl) o                Skip offset+length-1 < 0 || cntl < offset
                                       (max 0 offset), (min cntl (max 0 (offset + length - 1)))
                        x            new offset = offset - cntl
                                     new length = max 0 (length - (cntl - offset))
    *)
  let rev_ls2_raw ~offset ~length c =
    let {rev_path; cur; enc} = c in
    if not (Cursor.context cur).with_count then
      Lwt.return @@ FsError.error No_pagination_count
    else
      let rec f ~offset ~length acc segs cur =
        assert (length >= 0);
        if length = 0 then Lwt.return acc
        else
          let cnt, cur = Option.from_Some @@ Cursor.count cur in
          if offset+length-1 < 0 || cnt < offset then Lwt.return acc
          else
            let open Result in
            let open Option in
            let cur, v = Cursor.view cur in
            match v with
            | Bud (None, _, _) when segs = Segs.empty -> Lwt.return acc
            | Bud (Some _, _, _) when segs = Segs.empty ->
                let cur = from_Some @@ from_Ok @@ Cursor.go_below_bud cur in
                f ~offset ~length acc (Segs.push_bud segs) cur
            | Leaf _ | Bud _ ->
                let segs = Segs.to_segments segs in
                (* XXX path decoding each time... *)
                (* XXX error report *)
                let name =
                  match Utils.from_Some @@ Fs_nameenc.of_segments enc segs with
                  | [name] -> name
                  | [] -> assert false
                  | _ -> assert false
                in
                Lwt.return ((name, {cur; rev_path= name :: rev_path; enc})::acc)
            | Extender (seg, _, _, _) ->
                let cur = from_Ok @@ Cursor.go_down_extender cur in
                f ~offset ~length acc (Segs.append_seg segs seg) cur
            | Internal _ ->
                let curl = from_Ok @@ Cursor.go_side Left cur in
                let cntl, _ = Option.from_Some @@ Cursor.count curl in
                let curr = from_Ok @@ Cursor.go_side Right cur in
                let skipl = offset+length-1 < 0 || cntl <= offset in
                let offset' = max 0 (offset - cntl) in
                let length' = max 0 (length - (max 0 (cntl - (max 0 offset)))) in
                let*= acc =
                  if skipl then Lwt.return acc
                  else f ~offset ~length:(min cntl length) acc (Segs.add_side segs Left) curl
                in
                (* force Lwt context switch *)
                let*= () = Lwt.pause () in
                f ~offset:offset' ~length:length' acc (Segs.add_side segs Right) curr
      in
      (* XXX we can traverse in the opposite order *)
      let+= res = f ~offset ~length [] Segs.empty cur in
      Ok (c, res)

  let ls2 ~offset ~length path =
    let open Syntax in
    let+ res = at_dir "ls2" path @@ rev_ls2_raw ~offset ~length in
    List.rev res

  let run c op_lwt = op_lwt c
end

module Vc = struct
  open Result_lwt.Syntax

  type t =
    { vc : Vc.t
    ; enc : Fs_nameenc.t
    }

  let create ?hashcons ?node_cache ?lock ?resize_step_bytes
      ?auto_flush_seconds config enc path_prefix =
    let+=? vc =
      Vc.create ?hashcons ?node_cache ?lock ?resize_step_bytes
        ?auto_flush_seconds config path_prefix
    in
    { vc; enc }

  let open_existing_for_read ?hashcons ?node_cache config enc name =
    let+=? vc =
      Vc.open_existing_for_read ?hashcons ?node_cache config name
    in
    { vc; enc }

  let open_for_write ?hashcons ?node_cache ?resize_step_bytes
      ?auto_flush_seconds config enc name =
    let+=? vc =
      Vc.open_for_write ?hashcons ?node_cache ?resize_step_bytes
        ?auto_flush_seconds config name
    in
    { vc; enc }

  let close { vc; _ } = Vc.close vc

  let commit_db { vc; _ } = Vc.commit_db vc

  let context { vc; _ } = Vc.context vc

  let empty { vc; enc } = make (Vc.empty vc) enc []

  let of_value { vc; enc } v =
    let ctxt = Vc.context vc in
    let c = Cursor._Cursor (Cursor._Top, Node.new_leaf v, ctxt, Info.empty) in
    make c enc []

  let checkout { vc; enc } ch =
    let+= co = Vc.checkout vc ch in
    Option.map (fun c -> make c enc []) co

  let checkout' { vc; enc } ch =
    let+= cco = Vc.checkout' vc ch in
    Option.map (fun (commit, c) -> (commit, make c enc [])) cco

  let compute_commit_hash { vc; enc } ~parent c =
    let cur, ch = Vc.compute_commit_hash vc ~parent c.cur in
    (make cur enc [], ch)

  let commit ?allow_missing_parent { vc; enc } ~parent ~hash_override c =
    let+=? (cur,h,com) =
      Vc.commit ?allow_missing_parent vc ~parent ~hash_override c.cur
    in
    make cur enc [], (h, com)

  let flush { vc; _ } = Vc.flush vc

  let mem { vc; _ } = Vc.mem vc
end

module Merkle_proof = struct
  type t = Merkle_proof.t
  type detail = Path.t * Segment.segment list * Node_type.node option

  let encoding vc = Merkle_proof.encoding (Vc.context vc)

  let pp = Merkle_proof.pp

  let convert_details conv details =
    Result.mapM (fun (p, no) ->
        let segs = Plebeia__Path.to_segments p in
        match Fs_nameenc.of_segments conv segs with
        | Some path -> Ok (path, segs, no)
        | None -> FsError.error (Other ("merkle_proof", "invalid segment")))
      details

  let make paths ({ cur; enc; _ } as c) =
    let Cursor.Cursor (_, n, ctxt, _) = cur in
    let proof, details =
      Merkle_proof.make ctxt n (List.map (Fs_nameenc.to_segments enc) paths)
    in
    let+? details = convert_details enc details in
    (c, (proof, details))

  let check vc proof =
    let hasher = (Vc.context vc).hash in
    let (hp, seg), details = Merkle_proof.check hasher proof in
    (* cursor points to either Bud or Leaf, therefore seg must be empty *)
    if seg <> "" then FsError.error (Other ("Merkle_proof.check", "invalid long hash"))
    else
      let+? details = convert_details vc.enc details in
      (hp, details)
end