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_intf

module Path(Name : NAME) : PATH with type name = Name.t = struct

  type name = Name.t

  type t = Name.t list

  let length = List.length

  let rec equal ns1 ns2 = match ns1, ns2 with
    | [], [] -> true
    | n1::ns1, n2::ns2 when Name.equal n1 n2 -> equal ns1 ns2
    | _ -> false

  let to_string t =
    match t with
    | [] -> "empty_path"
    | _ -> String.concat "/" (List.map Name.to_string t)

  let pp ppf t = Format.pp_print_string ppf @@ to_string t

  let to_segments = List.map Name.to_segment

  let of_segments = Option.mapM Name.of_segment

  let is_prefix_of p1 p2 =
    let rec f p1 p2 =
      match p1, p2 with
      | [], _ -> Some p2
      | n1::p1, n2::p2 when Name.equal n1 n2 -> f p1 p2
      | _ -> None
    in
    f p1 p2
end

module Name8bits : NAME with type t = string = struct

  type t = string

  let equal (t1 : string) t2 = t1 = t2

  let to_string t = t

  let pp = Format.pp_print_string

  let to_segment s =
    Segment.unsafe_of_encoding (String.length s * 8 + 8)
      (s ^ "\000")

  let of_segment seg =
    let len, s = Segment.to_encoding seg in
    let slen = String.length s in
    if slen = 0 then begin
      Format.eprintf "seg? <%a>@." Segment.pp seg;
      assert (slen <> 0);
    end;
    if slen * 8 = len && s.[slen - 1] = '\000' then
      Some (String.sub s 0 (slen - 1))
    else None

  let test s =
    let seg = to_segment s in
    Format.eprintf "%s => %a@." s Segment.pp seg;
    match of_segment seg with
    | None ->
        Format.eprintf "%s => None@." s;
        assert false
    | Some s' ->
        Format.eprintf "%s => %s@." s s';
        assert (s = s')
end

module Name6bits = struct

  type t = string

  let equal (t1 : string) t2 = t1 = t2

  let to_string t = t

  let pp = Format.pp_print_string

  let encode =
    let c0 = Char.code '0' in
    let ca = Char.code 'a' in
    fun c ->
      let c' = Char.code c in
      match c with
      | '0'..'9' -> c' - c0 + 1 (* 1 .. 10 *)
      | 'a'..'z' -> c' - ca + 11 (* 11 .. 36 *)
      | '_' -> 37
      | '-' -> 38 (* big_map ID < 0 *)
      | c -> Format.eprintf "Unknown char %c@." c; assert false

  let decode =
    let c0 = Char.code '0' in
    let ca = Char.code 'a' in
    fun c ->
      if c = 0 then '\000'
      else if c <= 10 then Char.chr (c - 1 + c0)
      else if c <= 36 then Char.chr (c - 11 + ca)
      else if c = 37 then '_'
      else if c = 38 then '-'
      else assert false

  let to_segment s =
    let len = String.length s + 1 in
    let bits = len * 6 in
    let bytes = (bits + 7) / 8 in
    (* 543210 54|3210 5432|10 543210| .. *)
    let a = Array.init len (fun i ->
        if i = len - 1 then 0
        else encode @@ String.unsafe_get s i)
    in
(*
    Array.iteri (fun _i n -> Format.eprintf "%d;" n) a;
    Format.eprintf "@.";
*)
    let buf = String.init bytes (fun i ->                (*  i = 0, 1, 2, 3 *)
        let jl = i * 8 / 6 in                            (* jl = 0, 1, 2, 4 *)
        let jr = jl + 1 in                               (* jr = 1, 2, 3, 5 *)
        let shiftl = 8 - (jr * 6) mod 8 in           (* shiftl = 2, 4, 6, 2 *)
        let shiftr = 6 - shiftl in                   (* shiftr = 4, 2, 0, 4 *)
        let cl = Array.unsafe_get a jl in
        let cr = if jr >= len then 0 else Array.unsafe_get a jr in
        let c = ((cl lsl shiftl) + (cr lsr shiftr)) land 0xff in
        (* Format.eprintf "%d: %d <- %d %d -> %d ==> %d@." i cl shiftl cr shiftr c; *)
        Char.chr c)
    in
    Segment.unsafe_of_encoding bits buf

  let of_segment seg =
    let len, s = Segment.to_encoding seg in
    let slen = String.length s in
    if len mod 6 <> 0 then None
    else
      let chars = len / 6 - 1 in
      let f i =
        (* 543210 54|3210 5432|10 543210| .. *)
        let b = i * 6 / 8 in
        let shiftr = 10 - (i * 6) mod 8 in
        let c1 = String.unsafe_get s b in
        let c2 = if b + 1 < slen then String.unsafe_get s (b+1) else '\000' in
        decode (((Char.code c1 lsl 8 + Char.code c2) lsr shiftr) land 0b111111)
      in
      if f (len / 6) = '\000' then
        Some (String.init chars f)
      else None

  let test s =
    let seg = to_segment s in
    Format.eprintf "%s => %a@." s Segment.pp seg;
    match of_segment seg with
    | None ->
        Format.eprintf "%s => None@." s;
        assert false
    | Some s' ->
        Format.eprintf "%s => %s@." s s';
        assert (s = s')

(*
  let () =
    test "h";
    test "he";
    test "hel";
    test "hell";
    test "hello";
    test "hellow"
*)
end

module NameCompressed = struct

  (*
     Hex [0-9a-f]+, 2n chars, 2n >= 16
     :  4bits/char + 1 bit L flag, no terminator.
        Assuming all the file names at the same directory
        have the same length.

     Other Hex [0-9a-f]+
     :  5bits/char + 2 bit RL flag, 1 bit terminator

     Others:
     :  32bit hash + 2 bit RR flag
  *)

  include Name8bits

  let is_all_hex s len =
    let rec f i =
      match String.unsafe_get s i with
      | '0'..'9' | 'a'..'f' ->
          if i = 0 then true
          else f (i-1)
      | _ -> false
    in
    f (len-1)

  module H = Stdlib.Hashtbl
  let keyword_bytes = 2
  module B = Hashfunc.Blake2B(struct let bytes = keyword_bytes end)

  let tbl = H.create 100
  let tbl' = H.create 100

  let gen_hash s =
    let b4 = B.hash_string s in
    (* XXX can be optimized *)
    let seg0 = Segment.unsafe_of_encoding (keyword_bytes * 8) b4 in
    let seg = Segment.unfat [`Right; `Right; `Segment seg0] in
    let nseg0 = Segment.to_encoding seg0 in
    (seg, nseg0)

  let init dirs =
    let f s =
      let seg, nseg0 = gen_hash s in
      Hashtbl.replace tbl s seg;
      Hashtbl.replace tbl' nseg0 s in
    Hashtbl.reset tbl;
    Hashtbl.reset tbl';
    List.iter (fun dir ->
        let len = String.length dir in
        if is_all_hex dir len then ()
        else if String.unsafe_get dir 0 = '-' then begin
          let ss = String.sub dir 1 (len-1) in
          if is_all_hex ss (len-1) then ()
          else f dir end
        else f dir) dirs

  let c0 = Char.code '0'
  let ca = Char.code 'a'

  let encode5 neg s =
    let len = String.length s in
    let bits = len * 5 + 1 in
    let bytes = (bits + 7) / 8 in
    let enc i =
      if i > len then 0
      else if i = len then 0b10000
      else
        match String.unsafe_get s i with
        | '0'..'9' as c -> Char.code c - c0
        | 'a'..'f' as c -> Char.code c - ca + 10
        | _ -> assert false
    in
    (* f3210 f32|10 f3210 f|3210 f321|0 .. *)
    let buf = String.init bytes (fun i ->
        let j1 = i * 8 / 5 in
        let c1 = if j1 = 0 && neg then 0b10000 + enc j1 else enc j1 in
        let shift1 = 16 - (5 - (i * 8) mod 5) in
        let x1 = c1 lsl shift1 in

        let c2 = enc (j1+1) in
        let shift2 = shift1 - 5 in
        let x2 = if shift2 >= 0 then c2 lsl shift2 else c2 lsr (-shift2) in

        let c3 = enc (j1+2) in
        let shift3 = shift2 - 5 in
        let x3 = if shift3 >= 0 then c3 lsl shift3 else c3 lsr (-shift3) in

        let n = ((x1 + x2 + x3) lsr 8) land 255 in
        Char.chr n)
    in
    Segment.unsafe_of_encoding bits buf

  let decode5 seg =
    let neg =
      match Segment.get_side seg 0 with
      | Some Right -> true
      | _ -> false
    in
    let len, s = Segment.to_encoding seg in
    let slen = String.length s in
    if len mod 5 <> 1 then None
    else
      let chars = len / 5 in
      let f i =
        (* f3210 f32|10 f3210 f|3210 f321|0.. *)
        let b = i * 5 / 8 in
        let shiftr = 11 - ((i * 5) mod 8) in
        let c1 = Char.code @@ String.unsafe_get s b in
        let c2 = if b + 1 < slen then Char.code @@ String.unsafe_get s (b+1) else 0 in
        let x = ((c1 lsl 8 + c2) lsr shiftr) land 0b01111 in
        if x < 10 then Char.chr (c0 + x)
        else Char.chr (ca + x - 10)
      in
      let s = String.init chars f in
      if neg then Some ("-" ^ s) else Some s

  let to_segment s =
    let len = String.length s in
    let default s =
      match H.find_opt tbl s with
      | Some seg -> seg
      | None ->
          let seg, nseg0 = gen_hash s in
          H.replace tbl s seg;
          if H.mem tbl' nseg0 then assert false; (* collision *)
          H.replace tbl' nseg0 s;
          seg
    in
    if is_all_hex s len then
      if len >= 16 && len mod 2 = 0 then
        Segment.unfat [`Left; `Segment (Segment.unsafe_of_encoding (len * 4) (Hex.to_string (`Hex s)))]
      else
        Segment.unfat [`Right; `Left; `Segment (encode5 false s)]
    else if String.unsafe_get s 0 = '-' then
      let ss = String.sub s 1 (len-1) in
      if is_all_hex ss (len-1) then
        Segment.unfat [`Right; `Left; `Segment (encode5 true ss)]
      else
        default s
    else
      default s

  let of_segment seg =
    match Segment.get_side seg 0 with
    | None -> None
    | Some Left ->
        let seg = Segment.drop 1 seg in
        let nsides, s = Segment.to_encoding seg in
        assert (String.length s = nsides / 8);
        let `Hex h = Hex.of_string s in
        Some h
    | Some Right ->
        match Segment.get_side seg 1 with
        | None -> None
        | Some Left ->
            decode5 @@ Segment.drop 2 seg
        | Some Right ->
            let seg = Segment.drop 2 seg in
            match H.find_opt tbl' (Segment.to_encoding seg) with
            | Some n -> Some n
            | None ->
                Format.eprintf "seg RR %a@." Segment.pp seg; assert false

  let test s =
    Format.eprintf "%s => ...@." s;
    let seg = to_segment s in
    Format.eprintf "=> %a@." Segment.pp seg;
    match of_segment seg with
    | None ->
        Format.eprintf "%s => None@." s;
        assert false
    | Some s' ->
        Format.eprintf "%s => %s@." s s';
        assert (s = s');
        Format.eprintf "ok@."
end

module NameCompressed' = struct

  (*
     Hex [0-9a-f]+, 2n chars, 2n >= 16
     :  4bits/char + 1 bit L flag, no terminator.
        Assuming all the file names at the same directory
        have the same length.

     Other
     :  8bit/char
  *)

  include Name8bits

  let is_all_hex = NameCompressed.is_all_hex

  let to_segment s =
    let len = String.length s in
    if is_all_hex s len && len >= 16 && len mod 2 = 0 then
      Segment.unfat [`Left; `Segment (Segment.unsafe_of_encoding (len * 4) (Hex.to_string (`Hex s)))]
    else
      Segment.unfat [`Right; `Segment (Name8bits.to_segment s)]

  let of_segment seg =
    match Segment.get_side seg 0 with
    | None -> None
    | Some Left ->
        let seg = Segment.drop 1 seg in
        let nsides, s = Segment.to_encoding seg in
        assert (String.length s = nsides / 8);
        let `Hex h = Hex.of_string s in
        Some h
    | Some Right ->
        Name8bits.of_segment @@ Segment.drop 1 seg

  let test s =
    Format.eprintf "%s => ...@." s;
    let seg = to_segment s in
    Format.eprintf "=> %a@." Segment.pp seg;
    match of_segment seg with
    | None ->
        Format.eprintf "%s => None@." s;
        assert false
    | Some s' ->
        Format.eprintf "%s => %s@." s s';
        assert (s = s');
        Format.eprintf "ok@."
end

module NameCompressed'' = struct

  (*
     Hex [0-9a-f]+, 2n chars, 2n >= 16
     :  4bits/char + 1 bit L flag, no terminator.
        Assuming all the file names at the same directory
        have the same length.

     Other Hex [0-9a-f]+
     :  5bits/char + 2 bit RL flag, 1 bit terminator

     Other
     :  8bit/char
  *)

  include Name8bits

  let is_all_hex = NameCompressed.is_all_hex
  let encode5 = NameCompressed.encode5
  let decode5 = NameCompressed.decode5

  let default s =
    Segment.unfat [`Right; `Right; `Segment (Name8bits.to_segment s)]

  let to_segment s =
    let len = String.length s in
    if is_all_hex s len then
      if len >= 16 && len mod 2 = 0 then
        Segment.unfat [`Left; `Segment (Segment.unsafe_of_encoding (len * 4) (Hex.to_string (`Hex s)))]
      else
        Segment.unfat [`Right; `Left; `Segment (encode5 false s)]
    else if String.unsafe_get s 0 = '-' then
      let ss = String.sub s 1 (len-1) in
      if is_all_hex ss (len-1) then
        Segment.unfat [`Right; `Left; `Segment (encode5 true ss)]
      else
        default s
    else
      default s

  let of_segment seg =
    match Segment.get_side seg 0 with
    | None -> None
    | Some Left ->
        let seg = Segment.drop 1 seg in
        let nsides, s = Segment.to_encoding seg in
        assert (String.length s = nsides / 8);
        let `Hex h = Hex.of_string s in
        Some h
    | Some Right ->
        match Segment.get_side seg 1 with
        | None -> None
        | Some Left ->
            decode5 @@ Segment.drop 2 seg
        | Some Right ->
            let seg = Segment.drop 2 seg in
            Name8bits.of_segment seg

  let test s =
    Format.eprintf "%s => ...@." s;
    let seg = to_segment s in
    Format.eprintf "=> %a@." Segment.pp seg;
    match of_segment seg with
    | None ->
        Format.eprintf "%s => None@." s;
        assert false
    | Some s' ->
        Format.eprintf "%s => %s@." s s';
        assert (s = s');
        Format.eprintf "ok@."
end

module Segs = Segment.Segs

module MakeError(Path : PATH) = struct
  type error =
    | Is_file of string * Path.t
    | Is_directory of string * Path.t
    | No_such_file_or_directory of string * Path.t
    | File_or_directory_exists of string * Path.t
    | Path_decode_failure of Segment.t
    | Other of string * string

  type Error.t += FS_error of error

  let () =
    Error.register_printer
    @@ function
    | FS_error e ->
        Some
          ( match e with
            | Is_file (op, path) ->
                Format.asprintf "%s: it is a file: %a" op Path.pp path
            | Is_directory (op, path) ->
                Format.asprintf "%s: it is a directory: %a" op Path.pp path
            | No_such_file_or_directory (op, path) ->
                Format.asprintf
                  "%s: no such file or directory: %a"
                  op
                  Path.pp path
            | File_or_directory_exists (op, path) ->
                Format.asprintf
                  "%s: file or directory exists: %a"
                  op
                  Path.pp path
            | Path_decode_failure seg ->
                Format.asprintf
                  "path decode failure: %a" Segment.pp seg
            | Other (n, mes) ->
                Format.asprintf "%s: %s" n mes
          )
    | _ ->
        None

  let error_fs e = Error (FS_error e)
end

module Make(Name: NAME) = struct
  module Name = Name
  type name = Name.t
  module Path = Path(Name)

  type view = Node_type.view
  type raw_cursor = Cursor.t

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

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

  include MakeError(Path)

  let make cur path = { cur; rev_path= List.rev path }
  let empty context = make (Cursor.empty context) []
  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

  (* 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 } as c) =
      let p = Cursor.path_of_cursor cur in
      match Option.mapM Name.of_segment p with
      | None -> assert false
      | Some path ->
          assert (path = List.rev rev_path);
          Ok (c, ())

    let fail e : 'a t = fun _ -> error_fs 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 (Name.to_segment path) >>? fun cur ->
            Ok ({ cur; rev_path }, ())
          else
            Ok ({ 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 _ -> error_fs (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 = Name.to_segment p in
                Cursor.access_gen cur seg
                >>? (function
                    | Reached (_cur, Leaf _) ->
                        error_fs (Is_file ("chdir", List.rev rev_path))
                    | Reached (cur, Bud _) ->
                        seek path { 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 { cur; rev_path= p::rev_path }
                    | Empty_bud | Middle_of_extender _ ->
                        error_fs (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 _ ->
                error_fs (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 } = match path with
          | [] ->
              let (cur, v) = Cursor.view cur in
              begin match v with
                | Leaf _ | Bud _ ->
                    let c = { 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 = Name.to_segment 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 { cur; rev_path= p::rev_path }
                      | Empty_bud | Middle_of_extender _ ->
                          error_fs (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 _ ->
                  error_fs (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 } as c) = match path with
          | [] -> Ok (c, [])
          | p :: path ->
              let cur, v = Cursor.view cur in
              match v with
              | Bud _ ->
                  let seg = Name.to_segment p in
                  Cursor.access_gen cur seg
                  >>? (function
                      | Reached (cur, (Bud _ | Leaf _)) ->
                          seek path { 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 _ ->
                  error_fs (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 _)) -> error_fs (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 (Name.to_segment 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 = Name.to_segment 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 (Name.to_segment n) >>? fun cur ->
                          loop { cur; rev_path }
                      | Leaf _ | Internal _ | Extender _ -> assert false
                in
                loop c

      let set path c' c =
        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 (Path.to_segments (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 -> error_fs (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) -> error_fs (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 _ -> error_fs (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) -> error_fs (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

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

    (* The result is unspecified or unpredictable if the tree is modified
       during the traverse *)
    let traverse (acc, dests, segs, c) f =
      let rec next (acc, dests, segs, c) = match dests with
        | `Exit -> Ok (acc, `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, `Up (segs, dests), Segs.add_side segs Right, c)
      in
      let rec exit (acc, dests, segs, c) = match dests with
        | `Exit -> Ok (acc, `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, `Up (segs, dests), Segs.push_bud segs, c)
              end
          | Internal (_, _, _, _) ->
              Lwt.return begin
                Cursor.go_side Left c >>? fun c ->
                Ok (acc, `Up (segs, `Right dests), Segs.add_side segs Left, c)
              end
          | Extender (seg, _, _, _) ->
              Lwt.return begin
                Cursor.go_down_extender c >>? fun c ->
                Ok (acc, `Up (segs, dests), Segs.append_seg segs seg, c)
              end

    let raw_fold init c f =
      let rec loop x =
        Lwt.bind (traverse x f) @@ function
        | Error e -> Lwt.return_error e
        | Ok (acc, `Exit, _, c) -> Lwt.return_ok (c, acc)
        | Ok x -> Lwt.(pause () >>= fun () -> loop x)
      in
      loop (init, `Exit, Segs.empty, c)

    let fold_here init
        (* need a type constraint to have a simpler type *)
        (f : 'a -> Path.t -> cursor -> ([`Continue | `Exit | `Up] * 'a, Error.t) result Lwt.t)
        { cur; rev_path } =
      Lwt.map
        (function
          | Error e -> Error e
          | Ok (c,a) -> Ok ({ cur=c; rev_path }, 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 @@ Path.of_segments segs in
                 f acc path { cur=c; rev_path= List.rev_append path rev_path }))

    let fold'_here ?depth init f : _ 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
            Lwt.map
              (function
                | Error _ as e -> e
                | Ok acc -> Ok (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 @@ error_fs (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
      fold' ~depth:(`Eq 1) [] path0 f c

    let run c op_lwt = op_lwt c
  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 details =
      Result.mapM (fun (p, no) ->
          let segs = Plebeia__Path.to_segments p in
          match Path.of_segments segs with
          | Some path -> Ok (path, segs, no)
          | None -> error_fs (Other ("merkle_proof", "invalid segment")))
        details

    let make paths ({ cur; _ } as c) =
      let Cursor.Cursor (_, n, ctxt, _) = cur in
      let proof, details = Merkle_proof.make ctxt n (List.map Path.to_segments paths) in
      let+? details = convert_details 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 error_fs (Other ("Merkle_proof.check", "invalid long hash"))
      else
        let+? details = convert_details details in
        (hp, details)
  end

  module Vc = struct
    type t = Vc.t

    let create = Vc.create
    let open_ = Vc.open_
    let close = Vc.close
    let commit_db = Vc.commit_db
    let context = Vc.context

    let empty vc = make (Vc.empty vc) []

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

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

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

    let compute_commit_hash t ~parent c =
      let cur, ch = Vc.compute_commit_hash t ~parent c.cur in
      (make cur [], ch)

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

    let flush = Vc.flush

    let mem = Vc.mem
  end

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