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

module type NAME = Fs_intf.NAME
module type PATH = Fs_intf.PATH

module Make(Base : Fs_intf.BASE) = struct

  module Name = Base.Name
  module Path = Base.Path
  module FsError = Base.FsError

  module FSC = Fs_impl.Make(Base)
  open FSC

  type name = Name.t

  type raw_cursor = Cursor.t

  type tree = FSC.cursor

  type cursor = FSC.cursor

  type view = Node_type.view

  type hash = Hash.Prefix.t

  type error = FsError.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.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 of_cursor c = c
  let to_cursor c = c

  module Op = struct
    include Op.Monad

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

    let check_tree_invariant = 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 -> 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 = split path in
      let ups, path = relative path c in
      chdir_parents ups c >>? f (path @ [n])

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

    let get_tree = get

    let cat path = with_move path Op.Loose.cat

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

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

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

    let set_tree path tree c =
      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 @@ Op.Loose.rm ?recursive ?ignore_error

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

    let compute_hash path =
      with_move path @@ fun path c ->
      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 ->
      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 cursor 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 cursor = lift Op.cursor

    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 (Op_lwt.fold_here init (fun a path c -> f a path { c with rev_path = [] }))

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

    (* We assume that Buds and directories correspond with each other *)
    let ls = fun path0 c ->
      let f a path tree =
        match path with
        | [] | _::_::_ -> assert false
        | [name] -> Lwt.return @@ Ok ((name, {tree with rev_path = []}) :: a)
      in
      fold' ~depth:(`Eq 1) [] path0 f c
  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 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 Path.to_segments paths) in
      let+? details = FSC.Merkle_proof.convert_details details in
      (c, (proof, details))
  end

  module Vc = FSC.Vc
end