Source file fs_tree.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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Result_lwt.Syntax
open Result_lwt.Infix
open Fs_types

type name = Name.t

module Name = Name
module Path = Path
module FsError = FsError

module FSC = Fs_impl

type tree = FSC.cursor

type error = FSC.error

type raw_cursor = FSC.raw_cursor

type view = Node_type.view

type hash = Hash.Prefix.t

let make = FSC.make

let empty = FSC.empty

let context = FSC.context

let get_raw_cursor = FSC.get_raw_cursor

let relative path c =
  let cpath = List.rev c.FSC.rev_path in
  let rec loop cpath path =
    match cpath, path with
    | cn::cpath', n::path' ->
      if Name.equal cn n then loop cpath' path'
      else List.length cpath, path
    | _ -> List.length cpath, path
  in
  loop cpath path

let index tree = Cursor.index @@ get_raw_cursor tree

let forget_info tree = { tree with FSC.cur = Cursor.forget_info @@ get_raw_cursor tree }

let top_tree tree =
    let enc = tree.FSC.enc in
    make (Cursor.go_top @@ get_raw_cursor tree) enc []

let compute_hash tree =
  let cur, h = Cursor.compute_hash @@ get_raw_cursor tree in
  Fs_impl.{ tree with cur }, h

let write_top_tree tree =
  let open Result_lwt.Syntax in
  let+? (raw_cursor, index, hash) = Cursor.Cursor_storage.write_top_cursor @@ get_raw_cursor tree in
  (make raw_cursor tree.enc [], (index, hash))

let may_forget tree =
  match Cursor.may_forget @@ get_raw_cursor tree with
  | Some cur -> { tree with cur }
  | None -> tree

module Op = struct
  include FSC.Op.Monad

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

  let check_tree_invariant = FSC.Op.check_cursor_invariant

  let fail = FSC.Op.fail
  let raw_cursor = FSC.Op.raw_cursor
  let do_then = FSC.Op.do_then
  let run = FSC.Op.run

  let rec chdir_parents n c =
    match n with
    | 0 -> Ok c
    | n -> FSC.Op.chdir_parent c >>? fun (c,()) -> chdir_parents (n-1) c

  let with_move path f = fun c ->
    let ups, path = relative path c in
    chdir_parents ups c >>? f path

  let with_move' path f = fun c ->
    let path, n = FSC.split path in
    let ups, path = relative path c in
    chdir_parents ups c >>? f (path @ [n])

  let get path c =
    with_move path FSC.Op.Loose.get c
    >|? fun (c, (c', v)) -> (c, ({c' with rev_path = []}, v))

  let get_tree = get

  let cat path = with_move path FSC.Op.Loose.cat

  let write path value =
    with_move' path @@ fun path -> FSC.Op.Loose.write path value

  let _unlink path check =
    with_move' path @@ fun path -> FSC.Op.Loose.unlink path check

  let set path c' =
    with_move' path @@ fun path -> FSC.Op.Loose.set path c'

  let set_tree path tree c =
    FSC.Op.chdir_root tree >>? fun (tree, ()) ->
    set path tree 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_move' path @@ FSC.Op.Loose.rm ?recursive ?ignore_error

  let rmdir ?ignore_error path =
    with_move' path @@ FSC.Op.Loose.rmdir ?ignore_error

  let compute_hash path =
    with_move path @@ fun path c ->
    FSC.Op.Loose.seek path c >>? fun (c, _v) ->
    let cur, h = Cursor.compute_hash c.cur in
    let hp = fst h in
    assert (snd h = "");
    Ok ({c with cur}, hp)

  let may_forget path =
    with_move path @@ fun path c ->
    FSC.Op.Loose.seek path c >>? fun (c, _v) ->
    let cur =
      match Cursor.may_forget c.cur with
      | Some cur -> cur
      | None -> c.cur
    in
    Ok ({c with cur}, ())

  let tree c = Ok (c, c)
end

module Op_lwt = struct
  include FSC.Op_lwt.Monad

  let lift = FSC.Op_lwt.lift
  let lift_op = FSC.Op_lwt.lift_op
  let lift_lwt = FSC.Op_lwt.lift_lwt
  let lift_result = FSC.Op_lwt.lift_result
  let lift_result_lwt = FSC.Op_lwt.lift_result_lwt

  let fail e = lift (Op.fail e)
  let raw_cursor = lift Op.raw_cursor
  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 path = lift @@ Op.compute_hash path
  let may_forget path = lift @@ Op.may_forget path
  let do_then f g c = f c; g c
  let get_tree p = lift @@ Op.get_tree p
  let set_tree p t = lift @@ Op.set_tree p t
  let tree = lift Op.tree

  let run = FSC.Op_lwt.run

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

  let fold init path f : _ t =
    at_dir "fold" path
      (FSC.Op_lwt.fold_here init
         (fun a path c -> f a path { c with rev_path = [] }))

  let fold' ?depth init path f =
    at_dir "fold'" path
      (FSC.Op_lwt.fold'_here ?depth init
         (fun a path c -> f a path { c with rev_path = [] }))

  (* We assume that Buds and directories correspond with each other *)
  let ls path0 : (name * tree) list t = fun c ->
    let f a path tree =
      match path with
      | [] | _::_::_ -> assert false
      | [name] -> Lwt.return @@ Ok ((name, {tree with FSC.rev_path = []}) :: a)
    in
    Result_lwt.map (fun (c,xs) -> c, List.rev xs)
    @@ fold' ~depth:(`Eq 1) [] path0 f c

  let count : Path.t -> int t = fun path0 ->
    at_dir "count" path0 @@ fun c ->
    if not (Cursor.context c.cur).with_count then Lwt.return @@ FsError.error No_pagination_count
    else
      let cnt, cur = Option.from_Some @@ Cursor.count c.cur in
      Lwt.return @@ Ok ({ c with cur }, cnt)

  let ls2 ~offset ~length path : (name * tree) list t =
    at_dir "count" path @@ fun c ->
    let+=? c, xs = FSC.Op_lwt.rev_ls2_raw ~offset ~length c in
    c, List.rev_map (fun (name, c) -> (name, {c with FSC.rev_path= []})) xs
end

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

  let encoding = FSC.Merkle_proof.encoding
  let check = FSC.Merkle_proof.check
  let pp = FSC.Merkle_proof.pp

  let make from paths ({ FSC.enc; _ } as c) =
    FSC.Op.Loose.seek from c >>? fun ({ cur; _ } as c, _) ->
    let Cursor.Cursor (_, n, ctxt, _) = cur in
    let proof, details = Plebeia__Merkle_proof.make ctxt n (List.map (Fs_nameenc.to_segments enc) paths) in
    let+? details = FSC.Merkle_proof.convert_details enc details in
    (c, (proof, details))
end

module Vc = FSC.Vc