diff --git a/bantorra.opam b/bantorra.opam index 7efe6c5..ad736f3 100644 --- a/bantorra.opam +++ b/bantorra.opam @@ -13,14 +13,20 @@ dev-repo: "git+https://github.com/RedPRL/bantorra.git" depends: [ "dune" {>= "2.0"} "ocaml" {>= "5.0"} + "asai" + "algaeff" {>= "0.2"} "bos" {>= "0.2"} + "bwd" {>= "2.1"} "conf-git" {post} "ezjsonm" {>= "1.2"} + "json-data-encoding" {>= "0.9"} "ocamlfind" {>= "1.8"} "odoc" {with-doc} ] +pin-depends: [ + [ "asai.0.1.0~dev" "git+https://github.com/RedPRL/asai" ] +] build: [ - ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} diff --git a/src/basis/BantorraBasis.ml b/src/basis/BantorraBasis.ml index 9cecfb9..7b4e909 100644 --- a/src/basis/BantorraBasis.ml +++ b/src/basis/BantorraBasis.ml @@ -2,24 +2,22 @@ (** {1 Main Modules} *) +module UnitPath = UnitPath +(** Unit paths. *) + +module FilePath = FilePath +(** Basic path manipulation. *) + module File = File -(** Basic I/O and path manipulation. *) +(** Basic I/O. *) module Marshal = Marshal (** Serialization. *) -(**/**) +(** {1 Error Handling} *) -(** {1 Helper Modules} *) +module ErrorCode = ErrorCode +(** Error codes. *) module Error = Error -(** Generic error reporting functions. *) - -module Errors = Errors -(** Specialized error reporting functions. *) - -module Util = Util -(** Utility functions. *) - -module ResultMonad = ResultMonad -(** The {!type:result} monad. *) +(** Error reporting. *) diff --git a/src/basis/Error.ml b/src/basis/Error.ml index 5d4c6ae..1f5048a 100644 --- a/src/basis/Error.ml +++ b/src/basis/Error.ml @@ -1,20 +1 @@ -let[@inline] error_msg ~tag ~src msg = - Format.kasprintf tag "Reported from %s:\n %s" src msg - -let error_msgf ~tag ~src = - Format.kasprintf (error_msg ~tag ~src) - -let append_tag ~tag ~earlier = - Format.kasprintf tag "%s\n%s" earlier - -let append_error_msg ~tag ~earlier = - error_msg ~tag:(append_tag ~tag ~earlier) - -let append_error_msgf ~tag ~earlier = - error_msgf ~tag:(append_tag ~tag ~earlier) - -let pp_lines fmt msg = - Format.fprintf fmt "@["; - Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string) fmt @@ - String.split_on_char '\n' msg; - Format.fprintf fmt "@]" +include Asai.Logger.Make(ErrorCode) diff --git a/src/basis/Error.mli b/src/basis/Error.mli index 23e13e3..841a7e2 100644 --- a/src/basis/Error.mli +++ b/src/basis/Error.mli @@ -1,14 +1 @@ -val error_msg : tag:(string -> ('a, 'b) result) -> src:string -> string -> ('a, 'b) result -(** Turn an error message into an error. *) - -val error_msgf : tag:(string -> ('a, 'b) result) -> src:string -> ('c, Format.formatter, unit, ('a, 'b) result) format4 -> 'c -(** Format an error message. *) - -val append_error_msg : tag:(string -> ('a, 'b) result) -> earlier:string -> src:string -> string -> ('a, 'b) result -(** Append an error message to an earlier error. *) - -val append_error_msgf : tag:(string -> ('a, 'b) result) -> earlier:string -> src:string -> ('c, Format.formatter, unit, ('a, 'b) result) format4 -> 'c -(** Format and append an error message to an earlier error. *) - -val pp_lines : Format.formatter -> string -> unit -(** Pretty printer that hints newlines for ['\n']. *) +include Asai.Logger.S with module Code := ErrorCode diff --git a/src/basis/ErrorCode.ml b/src/basis/ErrorCode.ml new file mode 100644 index 0000000..94a2d22 --- /dev/null +++ b/src/basis/ErrorCode.ml @@ -0,0 +1,19 @@ +type t = + [ `System + | `AnchorNotFound + | `JSONFormat + | `UnitNotFound + | `InvalidLibrary + | `InvalidRouter + ] + +let default_severity _ = Asai.Severity.Error + +let to_string : t -> string = + function + | `System -> "sys" + | `AnchorNotFound -> "anchor" + | `JSONFormat -> "json" + | `UnitNotFound -> "unit" + | `InvalidLibrary -> "lib" + | `InvalidRouter -> "router" diff --git a/src/basis/Errors.ml b/src/basis/Errors.ml deleted file mode 100644 index 2c518b0..0000000 --- a/src/basis/Errors.ml +++ /dev/null @@ -1,20 +0,0 @@ -open ResultMonad.Syntax -open Error - -let tag msg = error @@ `SystemError msg -let error_system_msg ~src = error_msg ~tag ~src -let error_system_msgf ~src = error_msgf ~tag ~src -let append_error_system_msg ~src = append_error_msg ~tag ~src -let append_error_system_msgf ~src = append_error_msgf ~tag ~src - -let tag msg = error @@ `AnchorNotFound msg -let error_anchor_not_found_msg ~src = error_msg ~tag ~src -let error_anchor_not_found_msgf ~src = error_msgf ~tag ~src -let append_error_anchor_not_found_msg ~src = append_error_msg ~tag ~src -let append_error_anchor_not_found_msgf ~src = append_error_msgf ~tag ~src - -let tag msg = error @@ `FormatError msg -let error_format_msg ~src = error_msg ~tag ~src -let error_format_msgf ~src = error_msgf ~tag ~src -let append_error_format_msg ~src = append_error_msg ~tag ~src -let append_error_format_msgf ~src = append_error_msgf ~tag ~src diff --git a/src/basis/Errors.mli b/src/basis/Errors.mli deleted file mode 100644 index 8b2ba73..0000000 --- a/src/basis/Errors.mli +++ /dev/null @@ -1,22 +0,0 @@ -(** Error reporting functions *) - -(** {1 System Errors} *) - -val error_system_msg : src:string -> string -> ('a, [> `SystemError of string ]) Stdlib.result -val error_system_msgf : src:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `SystemError of string ]) Stdlib.result) Stdlib.format4 -> 'a -val append_error_system_msg : src:string -> earlier:string -> string -> ('a, [> `SystemError of string ]) Stdlib.result -val append_error_system_msgf : src:string -> earlier:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `SystemError of string ]) Stdlib.result) Stdlib.format4 -> 'a - -(** {1 Anchor Not Found} *) - -val error_anchor_not_found_msg : src:string -> string -> ('a, [> `AnchorNotFound of string ]) Stdlib.result -val error_anchor_not_found_msgf : src:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `AnchorNotFound of string ]) Stdlib.result) Stdlib.format4 -> 'a -val append_error_anchor_not_found_msg : src:string -> earlier:string -> string -> ('a, [> `AnchorNotFound of string ]) Stdlib.result -val append_error_anchor_not_found_msgf : src:string -> earlier:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `AnchorNotFound of string ]) Stdlib.result) Stdlib.format4 -> 'a - -(** {1 Format Errors} *) - -val error_format_msg : src:string -> string -> ('a, [> `FormatError of string ]) Stdlib.result -val error_format_msgf : src:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `FormatError of string ]) Stdlib.result) Stdlib.format4 -> 'a -val append_error_format_msg : src:string -> earlier:string -> string -> ('a, [> `FormatError of string ]) Stdlib.result -val append_error_format_msgf : src:string -> earlier:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `FormatError of string ]) Stdlib.result) Stdlib.format4 -> 'a diff --git a/src/basis/File.ml b/src/basis/File.ml index 2f215e6..0427f83 100644 --- a/src/basis/File.ml +++ b/src/basis/File.ml @@ -1,113 +1,63 @@ -open StdLabels -module U = UnixLabels -module E = Errors -open ResultMonad.Syntax +module U = Unix +module E = Error +module F = FilePath -type filepath = string +(* invariant: absolute path *) +type path = F.t -let (/) p1 p2 = - if Filename.is_relative p2 then Filename.concat p1 p2 else p2 +let (/) = F.add_unit_seg -let join = List.fold_left ~f:(/) ~init:Filename.current_dir_name +let wrap_bos = + function + | Ok r -> r + | Error (`Msg msg) -> E.fatalf `System "%s" msg (** Write a string to a file. *) -let writefile p s = - let src = "File.writefile" in - try - let ch = open_out_bin p in - Fun.protect ~finally:(fun () -> close_out_noerr ch) @@ - fun () -> - output_string ch s; - close_out ch; - ret () - with Sys_error msg -> E.error_system_msg ~src msg +let write p s = + E.tracef "File.write(%a)" F.pp p @@ fun () -> + wrap_bos @@ Bos.OS.File.write (F.to_fpath p) s (** Read the entire file as a string. *) -let readfile p = - let src = "File.readfile" in - try - let ch = open_in_bin p in - Fun.protect ~finally:(fun () -> close_in_noerr ch) @@ - fun () -> - let s = really_input_string ch (in_channel_length ch) in - close_in ch; - ret s - with Sys_error msg -> E.error_system_msg ~src msg - -let getcwd = Sys.getcwd - -(** OCaml implementation of [mkdir -p] *) -let rec ensure_dir path = - let src = "File.ensure_dir" in - match Sys.is_directory path with - | false -> - E.error_system_msgf ~src - "%s exists but is not a directory" path - | true -> ret () - | exception Sys_error _ -> - let parent = Filename.dirname path in - let* () = ensure_dir parent in - let rec loop () = - try ret @@ U.mkdir ~perm:0o777 path with - | U.Unix_error (U.EINTR, _, _) -> loop () (* try again *) - | U.Unix_error (e, _, _) -> - E.error_system_msg ~src @@ U.error_message e - in - loop () +let read p = + E.tracef "File.read(%a)" F.pp p @@ fun () -> + wrap_bos @@ Bos.OS.File.read (F.to_fpath p) -let normalize_dir dir = - let src = "File.normalize_dir" in - let rec loop () = - try ret @@ U.realpath dir with - | U.Unix_error (U.EINTR, _, _) -> loop () (* try again *) - | U.Unix_error (e, _, _) -> - E.error_system_msg ~src @@ U.error_message e - in - loop () +let get_cwd () = F.of_fpath @@ wrap_bos @@ Bos.OS.Dir.current () -let parent_of_normalized_dir dir = - let p = Filename.dirname dir in - if p = dir then None else Some p +let create_dir p = + E.tracef "File.create_dir(%a)" F.pp p @@ fun () -> + wrap_bos @@ Bos.OS.Dir.create (F.to_fpath p) let file_exists p = - try U.(stat p).st_kind = S_REG with _ -> false + wrap_bos @@ Bos.OS.File.exists (F.to_fpath p) let locate_anchor ~anchor start_dir = - let src = "File.locate_anchor" in - let rec find_root cwd path_acc = + E.tracef "File.locate_anchor(%s,%a)" anchor F.pp start_dir @@ fun () -> + let rec go cwd path_acc = if file_exists (cwd/anchor) then - ret (cwd, path_acc) + cwd, UnitPath.of_list path_acc else - match parent_of_normalized_dir cwd with - | None -> - E.error_anchor_not_found_msg ~src - "No anchor found all the way up to the root" - | Some parent -> - find_root parent @@ Filename.basename cwd :: path_acc + if F.is_root cwd + then E.fatalf `AnchorNotFound "No anchor found all the way up to the root" + else go (F.parent cwd) @@ F.basename cwd :: path_acc in - match normalize_dir start_dir with - | Ok cwd -> - find_root cwd [] - | Error (`SystemError msg) -> - E.append_error_anchor_not_found_msgf ~earlier:msg ~src - "%s is invalid" start_dir + go start_dir [] -let hijacking_anchors_exist ~anchor ~root = - function - | [] -> false - | first :: parts -> +let locate_hijacking_anchor ~anchor ~root path = + E.tracef "File.hijacking_anchors_exist(%s,%a)" anchor F.pp root @@ fun () -> + match UnitPath.to_list path with + | [] -> None + | first_seg :: segs -> let rec loop cwd parts = if file_exists (cwd/anchor) then - true + Some cwd else match parts with - | [] -> false - | part :: parts -> - loop (cwd/part) parts + | [] -> None + | seg :: segs -> + loop (cwd/seg) segs in - match normalize_dir (root/first) with - | Error (`SystemError _) -> false - | Ok cwd -> loop cwd parts + loop (root/first_seg) segs (** The scheme refers to how various directories should be determined. @@ -115,8 +65,6 @@ let hijacking_anchors_exist ~anchor ~root = [Linux] scheme covers all BSD-like systems and Cygwin on Windows. *) type scheme = MacOS | Linux | Windows -let getenv_opt = Sys.getenv_opt - let uname_s = lazy begin Result.to_option @@ @@ -138,121 +86,66 @@ let guess_scheme = end let get_home () = - match Lazy.force guess_scheme with - | Windows -> - begin - match getenv_opt "USERPROFILE" with - | Some userprofile -> Some userprofile - | None -> - match getenv_opt "HOMEPATH" with - | None -> None - | Some homepath -> - let drive = Option.value ~default:"" @@ Sys.getenv_opt "HOMEDRIVE" in - Some (drive/homepath) - end - | Linux | MacOS -> - match getenv_opt "HOME" with - | Some home -> Some home - | None -> - let rec loop () = - try - Some Unix.(getpwuid @@ getuid ()).pw_dir - with - | Not_found (* getpwuid *) -> None - | Unix.Unix_error (Unix.EINTR, _, _) -> loop () - | Unix.Unix_error _ -> None - in - loop () + F.of_fpath @@ wrap_bos @@ Bos.OS.Dir.user () -let expand_home = - (* ["~/"] in the most portable way *) - let home_prefix = "~" ^ Filename.dir_sep in - fun p -> - match get_home () with - | None -> p - | Some home -> - if p = "~" then - home - else if String.(length p >= length home_prefix) && - String.(sub ~pos:0 ~len:(length home_prefix) p = home_prefix) - then - home / String.sub ~pos:1 ~len:(String.length p - 1) p - else - p +let expand_home _ = + E.fatalf `System ~severity:Asai.Severity.Bug "expand_home not implemented yet" + +let read_env_path var = + Result.map (F.of_fpath ~cwd:(get_cwd ())) @@ Bos.OS.Env.path var (* XXX I did not test the following code on different platforms. *) -let get_xdg_config_home ?(macos_as_linux=false) ~app_name = - let src = "File.get_xdg_config_home" in - match getenv_opt "XDG_CONFIG_HOME" with - | Some dir -> ret @@ dir/app_name - | None -> - match Lazy.force guess_scheme, macos_as_linux with - | Linux, _ | MacOS, true -> - begin - match get_home () with - | None -> - E.error_system_msg ~src - "Both XDG_CONFIG_HOME and HOME are not set" - | Some home -> - ret @@ home/".config"/app_name - end - | MacOS, false -> - begin - match get_home () with - | None -> - E.error_system_msg ~src - "Both XDG_CONFIG_HOME and HOME are not set" - | Some home -> - ret @@ home/"Library"/"Application Support"/app_name - end - | Windows, _ -> +let get_xdg_config_home ~app_name = + E.tracef "File.get_xdg_config_home" @@ fun () -> + match read_env_path "XDG_CONFIG_HOME" with + | Ok dir -> dir/app_name + | Error _ -> + match Lazy.force guess_scheme with + | Linux -> + let home = + E.try_with get_home + ~fatal:(fun _ -> E.fatalf `System "Both XDG_CONFIG_HOME and HOME are not set") + in + home/".config"/app_name + | MacOS -> + let home = + E.try_with get_home + ~fatal:(fun _ -> E.fatalf `System "Both XDG_CONFIG_HOME and HOME are not set") + in + home/"Library"/"Application Support"/app_name + | Windows -> begin - match getenv_opt "APPDATA" with - | None -> - E.error_system_msg ~src - "Both XDG_CONFIG_HOME and APPDATA are not set" - | Some app_data -> - ret @@ app_data/app_name/"config" + match read_env_path "APPDATA" with + | Ok app_data -> + app_data/app_name/"config" + | Error _ -> + E.fatalf `System "Both XDG_CONFIG_HOME and APPDATA are not set" end (* XXX I did not test the following code on different platforms. *) -let get_xdg_cache_home ?(macos_as_linux=false) ~app_name = - let src = "File.get_xdg_cache_home" in - match Sys.getenv_opt "XDG_CACHE_HOME" with - | Some dir -> ret @@ dir/app_name - | None -> - match Lazy.force guess_scheme, macos_as_linux with - | Linux, _ | MacOS, true -> - begin - match get_home () with - | None -> - E.error_system_msg ~src - "Both XDG_CACHE_HOME and HOME are not set" - | Some home -> - ret @@ home/".cache"/app_name - end - | MacOS, false -> - begin - match get_home () with - | None -> - E.error_system_msg ~src - "Both XDG_CACHE_HOME and HOME are not set" - | Some home -> - ret @@ home/"Library"/"Caches"/app_name - end - | Windows, _ -> +let get_xdg_cache_home ~app_name = + E.tracef "File.get_xdg_cache_home" @@ fun () -> + match read_env_path "XDG_CACHE_HOME" with + | Ok dir -> dir/app_name + | Error _ -> + match Lazy.force guess_scheme with + | Linux -> + let home = + E.try_with get_home + ~fatal:(fun _ -> E.fatalf `System "Both XDG_CACHE_HOME and HOME are not set") + in + home/".cache"/app_name + | MacOS -> + let home = + E.try_with get_home + ~fatal:(fun _ -> E.fatalf `System "Both XDG_CACHE_HOME and HOME are not set") + in + home/"Library"/"Caches"/app_name + | Windows -> begin - match getenv_opt "LOCALAPPDATA" with - | None -> - E.error_system_msg ~src - "Both XDG_CACHE_HOME and LOCALAPPDATA are not set" - | Some local_app_data -> - ret @@ local_app_data/app_name/"cache" + match read_env_path "LOCALAPPDATA" with + | Error _ -> + E.fatalf `System "Both XDG_CACHE_HOME and LOCALAPPDATA are not set" + | Ok local_app_data -> + local_app_data/app_name/"cache" end - -let input_absolute_dir ?(starting_dir=Filename.current_dir_name) path = - normalize_dir (starting_dir / expand_home path) - -let input_relative_dir path = - if Filename.is_relative path then path - else Filename.(concat current_dir_name path) diff --git a/src/basis/File.mli b/src/basis/File.mli index 6e6c447..2c22dd6 100644 --- a/src/basis/File.mli +++ b/src/basis/File.mli @@ -1,56 +1,35 @@ -type filepath = string +(** {1 Path types} *) -(** {1 Pure Filename Calculation} *) - -val (/) : filepath -> filepath -> filepath -(** - [p / q] concatenates paths [p] and [q]. -*) - -val join : filepath list -> filepath -(** - The n-ary version of {!val:(/)} -*) +type path = FilePath.t (** {1 Basic I/O} *) -val writefile : filepath -> string -> (unit, [> `SystemError of string]) result +val write : path -> string -> unit (** - [writefile path str] writes the string [str] the file at [path] (in binary mode). + [write path str] writes the string [str] the file at [path] (in binary mode). If there was already a file at [path], it will be overwritten. *) -val readfile : filepath -> (string, [> `SystemError of string]) result +val read : path -> string (** - [readfile path] reads the content of string [str] the file at [path] (in binary mode). + [read path] reads the content of string [str] the file at [path] (in binary mode). If there was already a file at [path], it will be overwritten. *) (** {1 Directories} *) -val getcwd : unit -> filepath - -val ensure_dir : filepath -> (unit, [> `SystemError of string]) result -(** - [ensure_dir dir] effectively implements [mkdir dir] in OCaml. -*) - -val normalize_dir : filepath -> (filepath, [> `SystemError of string]) result -(** - [normalize_dir dir] uses [Sys.chdir] and [Sys.getcwd] to normalize a path. - The result will be an absolute path free of [.], [..], and symbolic links on many systems. -*) +val get_cwd : unit -> path -val parent_of_normalized_dir : filepath -> filepath option +val create_dir : path -> bool (** - [parent_of_normalized_dir dir] calculates the parent of a normalized directory [dir]. If [dir] is already the root directory, then this function returns [None]; otherwise it returns [Some parent] where [parent] is the parent directory. The result could be wrong if [dir] was not already normalized. + [create_dir dir] effectively implements [mkdir dir] in OCaml. Returns [true] if the directory is newly created. *) (** {1 Locating Files} *) -val file_exists : filepath -> bool +val file_exists : path -> bool -val locate_anchor : anchor:string -> filepath -> (filepath * string list, [> `AnchorNotFound of string]) result +val locate_anchor : anchor:string -> path -> path * UnitPath.t (** [locate_anchor ~anchor dir] finds the closest regular file named [anchor] in [dir] or its ancestors in the file system tree. @@ -65,29 +44,19 @@ val locate_anchor : anchor:string -> filepath -> (filepath * string list, [> `An and [locate_anchor ~anchor:"anchor.txt" "/usr"] will return ["/usr", []]. *) -val hijacking_anchors_exist : anchor:string -> root:filepath -> string list -> bool +val locate_hijacking_anchor : anchor:string -> root:path -> UnitPath.t -> path option (** {1 Special Directories} *) -val get_home : unit -> filepath option +val get_home : unit -> path -val expand_home : filepath -> filepath +val expand_home : path -> path (** Expand the beginning tilde to the home directory. *) -val get_xdg_config_home : ?macos_as_linux:bool -> app_name:string -> (filepath, [> `SystemError of string]) result +val get_xdg_config_home : app_name:string -> path (** Get the per-user config directory based on [XDG_CONFIG_HOME] with reasonable default values on major platforms. *) -val get_xdg_cache_home : ?macos_as_linux:bool -> app_name:string -> (filepath, [> `SystemError of string]) result +val get_xdg_cache_home : app_name:string -> path (** Get the per-user persistent cache directory based on [XDG_CACHE_HOME] with reasonable default values on major platforms. *) - -(**/**) - -(** {1 Getting User Inputs} *) - -val input_absolute_dir : ?starting_dir:filepath -> string -> (filepath, [> `SystemError of string]) result -(** Convenience function to get an absolute path from users. *) - -val input_relative_dir : string -> filepath -(** Convenience function to get a relative path from users. *) diff --git a/src/basis/FilePath.ml b/src/basis/FilePath.ml new file mode 100644 index 0000000..e606818 --- /dev/null +++ b/src/basis/FilePath.ml @@ -0,0 +1,44 @@ +module E = Error + +type t = Fpath.t (* must be an absolute, normalized path (no . or ..) *) + +let equal = Fpath.equal + +let compare = Fpath.compare + +let is_root = Fpath.is_root + +let parent = Fpath.parent + +let basename = Fpath.basename + +let has_ext = Fpath.has_ext + +let rem_ext = Fpath.rem_ext + +let add_ext = Fpath.add_ext + +let add_unit_seg p s = + UnitPath.assert_seg s; + Fpath.add_seg p s + +let append_unit p u = + if UnitPath.is_root u then p else + Fpath.append p (Fpath.v @@ UnitPath.to_string u) + +let of_fpath ?cwd p = + let p = match cwd with None -> p | Some cwd -> Fpath.append cwd p in + let p = Fpath.normalize p in + if Fpath.is_abs p then + p + else + E.fatalf `System "File path `%a' is not absolute" Fpath.pp p + +let to_fpath p = p + +let of_string ?cwd p = + match Fpath.of_string p with + | Error (`Msg msg) -> E.fatalf `System "Cannot parse file path `%s': %s" (String.escaped p) msg + | Ok p -> of_fpath ?cwd p + +let pp = Fpath.pp diff --git a/src/basis/FilePath.mli b/src/basis/FilePath.mli new file mode 100644 index 0000000..9ad8b6c --- /dev/null +++ b/src/basis/FilePath.mli @@ -0,0 +1,17 @@ +(** Absolute file paths *) + +type t +val equal : t -> t -> bool +val compare : t -> t -> int +val is_root : t -> bool +val parent : t -> t +val basename : t -> string +val has_ext : string -> t -> bool +val add_ext : string -> t -> t +val rem_ext : t -> t +val add_unit_seg : t -> string -> t +val append_unit : t -> UnitPath.t -> t +val of_fpath : ?cwd:t -> Fpath.t -> t +val to_fpath : t -> Fpath.t +val of_string : ?cwd:t -> string -> t +val pp : Format.formatter -> t -> unit diff --git a/src/basis/Marshal.ml b/src/basis/Marshal.ml index 48d7e99..8f5d31e 100644 --- a/src/basis/Marshal.ml +++ b/src/basis/Marshal.ml @@ -1,102 +1,27 @@ -module E = Errors -open ResultMonad.Syntax -open File +module E = Error -type value = Ezjsonm.value +let destruct enc json = + try + Json_encoding.destruct enc json + with e -> + E.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e -let of_json p = - let src = "Marshal.of_json" in - try ret @@ Ezjsonm.value_from_string p with - | Ezjsonm.Parse_error (_, msg) -> E.error_format_msg ~src msg -let read_json path = readfile path >>= of_json +let construct enc data = + try + Json_encoding.construct enc data + with e -> + E.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e -let to_json ?(minify=true) j = Ezjsonm.value_to_string ~minify j -let write_json ?minify path j = writefile path @@ to_json ?minify j +let parse s = + try Ezjsonm.value_from_string s with + | Ezjsonm.Parse_error (_, msg) -> + E.fatalf `JSONFormat "%s" msg -let dump fmt j = Format.pp_print_string fmt (to_json ~minify:true j) +let read enc path = + File.read path |> parse |> destruct enc -let of_string s = `String s -let to_string : value -> (string, [> `FormatError of string]) result = - let src = "Marshal.to_string" in - function - | `String s -> ret s - | v -> E.error_format_msgf ~src "Not a string: %a" dump v +let serialize ?(minify=true) enc data = + data |> construct enc |> Ezjsonm.value_to_string ~minify -let of_ostring = - function - | None -> `Null - | Some s -> `String s -let to_ostring = - let src = "Marshal.to_ostring" in - function - | `String str -> ret @@ Some str - | `Null -> ret None - | v -> E.error_format_msgf ~src "Not a string or null: %a" dump v - -let of_list of_item l = - `A (List.map of_item l) -let to_list to_item = - let src = "Marshal.to_list" in - function - | `A items -> ResultMonad.map to_item items - | v -> E.error_format_msgf ~src "Not a list: %a" dump v - -let of_olist of_item = - function - | None -> `Null - | Some l -> of_list of_item l -let to_olist to_item = - let src = "Marshal.to_olist" in - function - | `A items -> - let+ l = ResultMonad.map to_item items in Some l - | `Null -> ret None - | v -> E.error_format_msgf ~src "Not a list or null: %a" dump v - -let parse_object_fields ?(required=[]) ?(optional=[]) ms = - let src = "Marshal.parse_object_fields" in - let fields = Hashtbl.create 10 in - let* () = ResultMonad.iter (fun f -> - match Hashtbl.find_opt fields f with - | Some _ -> - E.error_format_msgf ~src "Duplicate fields `%s' in the field specification." f - | None -> ret @@ Hashtbl.replace fields f None - ) (required @ optional) - in - let* () = - ResultMonad.iter (fun (f, v) -> - match Hashtbl.find_opt fields f with - | None -> - E.error_format_msgf ~src "Unexpected field `%s' in %a" f dump (`O ms) - | Some (Some _) -> - E.error_format_msgf ~src "Duplicate fields `%s' in %a" f dump (`O ms) - | Some None -> - ret @@ Hashtbl.replace fields f (Some v) - ) ms - in - let* values_requred = ResultMonad.map (fun f -> - match Hashtbl.find fields f with - | Some v -> ret (f, v) - | None -> - E.error_format_msgf ~src "Required field `%s' missing in %a" f dump (`O ms) - ) required - and* values_optional = ResultMonad.map (fun f -> - match Hashtbl.find fields f with - | Some v -> ret (f, v) - | None -> ret (f, `Null) - ) optional - in - ret (values_requred, values_optional) - -let parse_object ?required ?optional = - let src = "Marshal.parse_object" in - function - | `O ms -> parse_object_fields ?required ?optional ms - | v -> E.error_format_msgf ~src "Not an object: %a" dump v - -let parse_object_or_null ?required ?optional = - let src = "Marshal.parse_object_or_null" in - function - | `Null -> ret None - | `O ms -> Option.some <$> parse_object_fields ?required ?optional ms - | v -> E.error_format_msgf ~src "Not an object or null: %a" dump v +let write ?(minify=false) enc path data = + data |> serialize ~minify enc |> File.write path diff --git a/src/basis/Marshal.mli b/src/basis/Marshal.mli index 682ba98..1a65973 100644 --- a/src/basis/Marshal.mli +++ b/src/basis/Marshal.mli @@ -1,63 +1,10 @@ -(** {1 Types} *) - -type value = Ezjsonm.value -(** The type suitable for marshalling. This is the universal type to exchange information - within the framework. *) - (** {1 Serialization} *) -val of_json : string -> (value, [> `FormatError of string]) result -(** A function that deserializes a value. *) - -val read_json : string -> (value, [> `FormatError of string | `SystemError of string ]) result -(** [read_json path v] reads and deserializes the content of the file at [path]. *) - -val to_json : ?minify:bool -> value -> string -(** A function that serializes a value. *) - -val write_json : ?minify:bool -> string -> value -> (unit, [> `FormatError of string | `SystemError of string]) result -(** [unsafe_write_json path v] writes the serialization of [v] into the file at [path]. *) - -(** {1 Helper Functions} *) - -val of_string : string -> value -(** Embedding a string into a {!type:value}. *) - -val to_string : value -> (string, [> `FormatError of string]) result -(** Projecting a string out of a {!type:value}. *) - -val of_ostring : string option -> value -(** Embedding an optional string into a {!type:value}. *) - -val to_ostring : value -> (string option, [> `FormatError of string]) result -(** Projecting an optional string out of a {!type:value}. *) - -val of_list : ('a -> value) -> 'a list -> value -(** Embedding a list into a {!type:value}. *) - -val to_list : (value -> ('a, [> `FormatError of string] as 'e) result) -> value -> ('a list, 'e) result -(** Projecting a list out of a {!type:value}. *) - -val of_olist : ('a -> value) -> 'a list option -> value -(** Embedding an optional list into a {!type:value}. *) - -val to_olist : (value -> ('a, [> `FormatError of string] as 'e) result) -> value -> ('a list option, 'e) result -(** Projecting an optional list out of a {!type:value}. *) - -val parse_object : - ?required:string list -> ?optional:string list -> value -> - ((string * value) list * (string * value) list, [> `FormatError of string ]) result -(** Projecting an associative list out of a {!type:value}. - - @param required Names of required fields. By default, it is [[]]. - @param optional Names of optional fields. By default, it is [[]]. - @return A pair of an associative list for required fields and that for optional fields. Missing optional fields will be associated with [`Null]. In other words, a missing ["opt"] field in a JSON object is treated as ["opt": null]. -*) +val read : 'a Json_encoding.encoding -> File.path -> 'a +(** [read enc path] reads and deserializes the content of the file at [path]. *) -val parse_object_or_null : - ?required:string list -> ?optional:string list -> value -> - (((string * value) list * (string * value) list) option, [> `FormatError of string ]) result -(** Projecting an optional associative list out of a {!type:value}. See {!val:parse_object}. *) +val write : ?minify:bool -> 'a Json_encoding.encoding -> File.path -> 'a -> unit +(** [write enc path v] writes the serialization of [v] into the file at [path]. *) -val dump : Format.formatter -> value -> unit -(** An ugly-printer for {!type:value}. *) +val serialize : ?minify:bool -> 'a Json_encoding.encoding -> 'a -> string +(** [serialize] is like [write], but returning the string instead of writing it to a file. *) diff --git a/src/basis/ResultMonad.ml b/src/basis/ResultMonad.ml deleted file mode 100644 index 88faaba..0000000 --- a/src/basis/ResultMonad.ml +++ /dev/null @@ -1,37 +0,0 @@ -module Syntax = -struct - let ret = Result.ok - let error = Result.error - let (>>=) = Result.bind - let (<$>) = Result.map - let (let*) = Result.bind - let[@inline] (and*) m n = let* m in let* n in ret (m, n) - let[@inline] (let+) m f = Result.map f m - let (and+) = (and*) -end - -open Syntax - -let ignore_error m = Result.value ~default:() m - -let rec map f = - function - | [] -> ret [] - | x :: xs -> - let+ y = f x - and+ ys = map f xs in - y :: ys - -let rec iter f = - function - | [] -> ret () - | x :: xs -> - let* () = f x in - iter f xs - -let rec iter_seq f s = - match s () with - | Seq.Nil -> ret () - | Seq.Cons (x, xs) -> - let* () = f x in - iter_seq f xs diff --git a/src/basis/ResultMonad.mli b/src/basis/ResultMonad.mli deleted file mode 100644 index 4e2d7cb..0000000 --- a/src/basis/ResultMonad.mli +++ /dev/null @@ -1,16 +0,0 @@ -module Syntax : -sig - val ret : 'a -> ('a, 'e) result - val error : 'e -> ('a, 'e) result - val (>>=) : ('a, 'e) result -> ('a -> ('c, 'e) result) -> ('c, 'e) result - val (<$>) : ('a -> 'b) -> ('a, 'e) result -> ('b, 'e) result - val (let*) : ('a, 'e) result -> ('a -> ('c, 'e) result) -> ('c, 'e) result - val (and*) : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e) result - val (let+) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result - val (and+) : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e) result -end - -val ignore_error : (unit, 'e) result -> unit -val map : ('a -> ('b, 'e) result) -> 'a list -> ('b list, 'e) result -val iter : ('a -> (unit, 'b) result) -> 'a list -> (unit, 'b) result -val iter_seq : ('a -> (unit, 'b) result) -> 'a Seq.t -> (unit, 'b) result diff --git a/src/basis/UnitPath.ml b/src/basis/UnitPath.ml new file mode 100644 index 0000000..81ad3e4 --- /dev/null +++ b/src/basis/UnitPath.ml @@ -0,0 +1,41 @@ +module E = Error + +type t = string list (* all segments must be non-empty and satisfy Fpath.is_seg *) + +let equal = List.equal String.equal + +let compare = List.compare String.compare + +let root : t = [] + +let is_root l = l = root + +let is_seg s = s <> "" && Fpath.is_seg s && not (Fpath.is_rel_seg s) + +let assert_seg s = + if not (is_seg s) then + E.fatalf `InvalidLibrary "%s not a valid unit segment" s + +let of_seg s = assert_seg s; [s] + +let add_seg u s = assert_seg s; u @ [s] + +let prepend_seg s u = assert_seg s; s :: u + +let to_list l = l + +let of_list l = List.iter assert_seg l; l + +let of_string p = + E.tracef "UnitPath.of_string(%s)" p @@ fun () -> + if p = "." then [] + else of_list @@ String.split_on_char '/' p + +let to_string = + function + | [] -> "." + | l -> String.concat "/" l + +let pp fmt l = Format.pp_print_string fmt (to_string l) + +let unsafe_of_list l = l diff --git a/src/basis/UnitPath.mli b/src/basis/UnitPath.mli new file mode 100644 index 0000000..bebb4e5 --- /dev/null +++ b/src/basis/UnitPath.mli @@ -0,0 +1,19 @@ +type t +val equal : t -> t -> bool +val compare : t -> t -> int +val root : t +val is_root : t -> bool +val is_seg : string -> bool +val assert_seg : string -> unit +val of_seg : string -> t +val add_seg : t -> string -> t +val prepend_seg : string -> t -> t +val to_list : t -> string list +val of_list : string list -> t +val of_string : string -> t +val to_string : t -> string +val pp : Format.formatter -> t -> unit + +(**/**) + +val unsafe_of_list : string list -> t diff --git a/src/basis/Util.ml b/src/basis/Util.ml deleted file mode 100644 index 2f2282f..0000000 --- a/src/basis/Util.ml +++ /dev/null @@ -1,25 +0,0 @@ -open ResultMonad.Syntax - -module Hashtbl = -struct - let of_unique_seq (type key) seq = - let exception DuplicateKeys of key in - let tbl = Hashtbl.create 0 in - try - Seq.iter (fun (k, v) -> - if Hashtbl.mem tbl k then - raise @@ DuplicateKeys k - else begin - Hashtbl.replace tbl k v - end) seq; - ret tbl - with - | DuplicateKeys k -> error @@ `DuplicateKeys k - - let of_unique_list l = - of_unique_seq @@ List.to_seq l -end - -let string_of_path = String.concat "." - -let pp_path fmt path = Format.pp_print_string fmt @@ string_of_path path diff --git a/src/basis/Util.mli b/src/basis/Util.mli deleted file mode 100644 index 64280e8..0000000 --- a/src/basis/Util.mli +++ /dev/null @@ -1,9 +0,0 @@ -module Hashtbl : -sig - val of_unique_seq : ('a * 'b) Seq.t -> (('a, 'b) Hashtbl.t, [> `DuplicateKeys of 'a]) result - (** This is similar to [Hashtbl.of_seq] except that it will abort when there are duplicate keys. *) - - val of_unique_list : ('a * 'b) list -> (('a, 'b) Hashtbl.t, [> `DuplicateKeys of 'a]) result -end - -val pp_path : Format.formatter -> string list -> unit diff --git a/src/basis/dune b/src/basis/dune index 82dd4f7..439b056 100644 --- a/src/basis/dune +++ b/src/basis/dune @@ -1,5 +1,12 @@ (library (name BantorraBasis) (public_name bantorra.basis) - (flags (:standard -w -16)) - (libraries bos ezjsonm unix)) + (libraries + algaeff + asai + bos + bwd + ezjsonm + fpath + json-data-encoding + unix)) diff --git a/src/manager/Anchor.ml b/src/manager/Anchor.ml index f90c3ea..858dfa5 100644 --- a/src/manager/Anchor.ml +++ b/src/manager/Anchor.ml @@ -1,86 +1,27 @@ +module J = Json_encoding open BantorraBasis -open ResultMonad.Syntax - -let version = "1.0.0" - -type path = string list -type router_name = string -type router_argument = Router.argument +module E = Error type t = - { routes : (path, router_name * router_argument) Hashtbl.t - ; cache : (path, (router_name * router_argument * path) option) Hashtbl.t - } + { routes : Router.route Trie.t } -module M = +module Enc = struct - let to_path = Marshal.(to_list to_string) + let version v = J.req ~title:"version" ~description:"format version" "version" (J.constant v) + (* let source_dir = J.dft ~title:"Source directory" ~description:"source directory (default: \"./\")" "source_dir" J.string "./" *) + let routes = J.dft ~title:"Routes" ~description:"routes" "routes" (J.assoc J.any_ezjson_value) [] - let to_route v = - Marshal.parse_object ~required:["mount_point"; "router"] ~optional:["router_argument"] v >>= - function - | ["mount_point", mount_point; "router", router], ["router_argument", router_argument] -> - let+ router = Marshal.to_string router - and+ prefix = to_path mount_point - in - prefix, (router, router_argument) - | _ -> assert false + let anchor v = J.obj2 (version v) routes end -let deserialize : Marshal.value -> (t, _) result = - let src = "Anchor.deserialize" in - let cache = Hashtbl.create 10 in - fun v -> - Marshal.parse_object_or_null ~required:["format"] ~optional:["routes"] v >>= - function - | None -> ret {routes = Hashtbl.create 0; cache} - | Some (["format", format], ["routes", routes]) -> - let* format = Marshal.to_string format in - if format <> version then - Errors.error_format_msgf ~src "Format version `%s' is not supported (only version `%s' is supported)" format version - else begin - let* routes = Option.value ~default:[] <$> Marshal.to_olist M.to_route routes in - match Util.Hashtbl.of_unique_seq @@ List.to_seq routes with - | Error (`DuplicateKeys k) -> - Errors.error_format_msgf ~src "Multiple libraries mounted at %a" Util.pp_path k - | Ok routes -> ret {routes; cache} - end - | _ -> assert false - -let read anchor = Marshal.read_json anchor >>= deserialize - -let iter_routes f {routes; _} = - Hashtbl.to_seq routes |> - ResultMonad.iter_seq (fun (_, (router, router_argument)) -> f ~router ~router_argument) - -let match_prefix path prefix k = - let rec loop path prefix acc = - match path, prefix with - | _, [] -> Some (acc, k path) - | [], _ -> None - | (id :: path), (id' :: prefix) -> - if String.equal id id' then loop path prefix (acc+1) else None - in loop path prefix 0 - -let match_route path (mount_point, (router, router_argument)) = - match_prefix mount_point path @@ fun path -> router, router_argument, path - -let max_match x y = - match x, y with - | Some (n0, _), (n1, _) when (n0 : int) >= n1 -> x - | _ -> Some y +let read ~version path : t = + let (), routes = Marshal.read (Enc.anchor version) path in + let routes = List.fold_right (fun (path, route) -> Trie.add (UnitPath.of_string path) route) routes Trie.empty in + { routes } -let dispatch_path_without_cache {routes; _} path = - let matched = Seq.filter_map (match_route path) @@ Hashtbl.to_seq routes in - Option.map snd @@ Seq.fold_left max_match None matched +let iter_routes f a = Trie.iter_values f a.routes -let dispatch_path anchor path = - match Hashtbl.find_opt anchor.cache path with - | Some ref -> ref - | None -> - let ref = dispatch_path_without_cache anchor path in - Hashtbl.replace anchor.cache path ref; - ref +let dispatch_path {routes; _} path = Trie.find path routes let path_is_local anchor path = Option.is_none @@ dispatch_path anchor path diff --git a/src/manager/Anchor.mli b/src/manager/Anchor.mli index 4f7ce09..e44f743 100644 --- a/src/manager/Anchor.mli +++ b/src/manager/Anchor.mli @@ -5,19 +5,16 @@ open BantorraBasis type t (** The type of anchors. *) -type path = string list -(** The type of unit paths. *) - (** {1 Anchor I/O} *) -val read : File.filepath -> (t, [> `FormatError of string | `SystemError of string ]) result +val read : version:string -> File.path -> t (** [read path] read the content of an anchor file. *) (** {1 Accessors} *) -val iter_routes : (router:string -> router_argument:Marshal.value -> (unit, 'e) result) -> t -> (unit, 'e) result +val iter_routes : (Router.route -> unit) -> t -> unit -val dispatch_path : t -> path -> (string * Marshal.value * path) option +val dispatch_path : t -> UnitPath.t -> (Router.route * UnitPath.t) option (** [dispatch_path a p] routes the unit path [p] to [Some (ref, p')] if it points to a unit in another library referenced by [ref] and [p'], or [None] if it is a local unit path. The dispatching is done by longest prefix match. *) -val path_is_local : t -> path -> bool +val path_is_local : t -> UnitPath.t -> bool diff --git a/src/manager/Bantorra.ml b/src/manager/Bantorra.ml index 4807afa..0c899e1 100644 --- a/src/manager/Bantorra.ml +++ b/src/manager/Bantorra.ml @@ -133,8 +133,3 @@ module Manager = Manager module Router = Router (** The type of routers. *) - -(** {1 Helper Modules} *) - -module Errors = Errors -(** Error reporting functions *) diff --git a/src/manager/Errors.ml b/src/manager/Errors.ml deleted file mode 100644 index f052c83..0000000 --- a/src/manager/Errors.ml +++ /dev/null @@ -1,28 +0,0 @@ -open BantorraBasis -open ResultMonad.Syntax - -include BantorraBasis.Errors - -let tag msg = error @@ `UnitNotFound msg -let error_unit_not_found_msg ~src = Error.error_msg ~tag ~src -let error_unit_not_found_msgf ~src = Error.error_msgf ~tag ~src -let append_error_unit_not_found_msg ~src = Error.append_error_msg ~tag ~src -let append_error_unit_not_found_msgf ~src = Error.append_error_msgf ~tag ~src -let open_error_unit_not_found = - function Ok _ as r -> r | Error (`UnitNotFound _) as r -> r - -let tag msg = error @@ `InvalidLibrary msg -let error_invalid_library_msg ~src = Error.error_msg ~tag ~src -let error_invalid_library_msgf ~src = Error.error_msgf ~tag ~src -let append_error_invalid_library_msg ~src = Error.append_error_msg ~tag ~src -let append_error_invalid_library_msgf ~src = Error.append_error_msgf ~tag ~src -let open_error_invalid_library = - function Ok _ as r -> r | Error (`InvalidLibrary _) as r -> r - -let tag msg = error @@ `InvalidRouter msg -let error_invalid_router_msg ~src = Error.error_msg ~tag ~src -let error_invalid_router_msgf ~src = Error.error_msgf ~tag ~src -let append_error_invalid_router_msg ~src = Error.append_error_msg ~tag ~src -let append_error_invalid_router_msgf ~src = Error.append_error_msgf ~tag ~src -let open_error_invalid_router = - function Ok _ as r -> r | Error (`InvalidRouter _) as r -> r diff --git a/src/manager/Errors.mli b/src/manager/Errors.mli deleted file mode 100644 index 5d8d6fb..0000000 --- a/src/manager/Errors.mli +++ /dev/null @@ -1,25 +0,0 @@ -include module type of BantorraBasis.Errors - -(** {1 Unit Not Found} *) - -val error_unit_not_found_msg : src:string -> string -> ('a, [> `UnitNotFound of string ]) Stdlib.result -val error_unit_not_found_msgf : src:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `UnitNotFound of string ]) Stdlib.result) Stdlib.format4 -> 'a -val append_error_unit_not_found_msg : src:string -> earlier:string -> string -> ('a, [> `UnitNotFound of string ]) Stdlib.result -val append_error_unit_not_found_msgf : src:string -> earlier:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `UnitNotFound of string ]) Stdlib.result) Stdlib.format4 -> 'a -val open_error_unit_not_found : ('a, [< `UnitNotFound of 'b ]) Stdlib.result -> ('a, [> `UnitNotFound of 'b ]) Stdlib.result - -(** {1 Invalid Libraries} *) - -val error_invalid_library_msg : src:string -> string -> ('a, [> `InvalidLibrary of string ]) Stdlib.result -val error_invalid_library_msgf : src:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `InvalidLibrary of string ]) Stdlib.result) Stdlib.format4 -> 'a -val append_error_invalid_library_msg : src:string -> earlier:string -> string -> ('a, [> `InvalidLibrary of string ]) Stdlib.result -val append_error_invalid_library_msgf : src:string -> earlier:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `InvalidLibrary of string ]) Stdlib.result) Stdlib.format4 -> 'a -val open_error_invalid_library : ('a, [< `InvalidLibrary of 'b ]) Stdlib.result -> ('a, [> `InvalidLibrary of 'b ]) Stdlib.result - -(** {1 Invalid Routers} *) - -val error_invalid_router_msg : src:string -> string -> ('a, [> `InvalidRouter of string ]) Stdlib.result -val error_invalid_router_msgf : src:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `InvalidRouter of string ]) Stdlib.result) Stdlib.format4 -> 'a -val append_error_invalid_router_msg : src:string -> earlier:string -> string -> ('a, [> `InvalidRouter of string ]) Stdlib.result -val append_error_invalid_router_msgf : src:string -> earlier:string -> ('a, Stdlib.Format.formatter, unit, ('b, [> `InvalidRouter of string ]) Stdlib.result) Stdlib.format4 -> 'a -val open_error_invalid_router : ('a, [< `InvalidRouter of 'b ]) Stdlib.result -> ('a, [> `InvalidRouter of 'b ]) Stdlib.result diff --git a/src/manager/Library.ml b/src/manager/Library.ml index c1142f9..e998c71 100644 --- a/src/manager/Library.ml +++ b/src/manager/Library.ml @@ -1,76 +1,65 @@ -module E = Errors open BantorraBasis -open ResultMonad.Syntax - -type path = Anchor.path +module E = Error type t = - { root : File.filepath + { root : File.path ; anchor : string ; loaded_anchor : Anchor.t } -let load_from_root ~find_cache ~anchor root = - let src = "Library.load_from_root" in +let (/) = FilePath.add_unit_seg + +let load_from_root ~version ~find_cache ~anchor root = + E.tracef "Library.load_from_root(%s,-,%s,%a)" version anchor FilePath.pp root @@ fun () -> match find_cache root with - | Some lib -> ret lib + | Some lib -> lib | None -> - match Anchor.read File.(root/anchor) with - | Ok loaded_anchor -> ret {root; anchor; loaded_anchor} - | Error (`SystemError msg | `FormatError msg) -> - E.append_error_invalid_library_msgf ~earlier:msg ~src - "Could not parse the anchor %s" File.(root/anchor) + let loaded_anchor = Anchor.read ~version (root/anchor) in + {root; anchor; loaded_anchor} -let load_from_dir ~find_cache ~anchor dir = - let src = "Library.load_from_dir" in +let load_from_dir ~version ~find_cache ~anchor dir = + E.tracef "Library.load_from_dir(%s,-,%s,%a)" version anchor FilePath.pp dir @@ fun () -> match File.locate_anchor ~anchor dir with - | Error (`AnchorNotFound msg) -> - E.append_error_invalid_library_msgf ~earlier:msg ~src - "Could not find any anchor in the ancestors of %s" dir - | Ok (root, prefix) -> - let+ lib = load_from_root ~find_cache ~anchor root in + | root, prefix -> + let lib = load_from_root ~version ~find_cache ~anchor root in if Anchor.path_is_local lib.loaded_anchor prefix then lib, Some prefix else lib, None -let load_from_unit ~find_cache ~anchor filepath ~suffix = - let src = "Library.load_from_unit" in +let load_from_unit ~version ~find_cache ~anchor filepath ~suffix = + E.tracef "Library.load_from_dir(%s,-,%s,%a,%s)" version anchor FilePath.pp filepath suffix @@ fun () -> if not @@ File.file_exists filepath then - E.error_invalid_library_msgf ~src - "The unit %s does not exist" filepath + E.fatalf `InvalidLibrary "The unit %a does not exist" FilePath.pp filepath else - match Filename.chop_suffix_opt ~suffix @@ Filename.basename filepath with - | None -> - E.error_invalid_library_msgf ~src - "The file path %s does not have the suffix `%s'" filepath suffix - | Some basename -> - let+ root, path_opt = - load_from_dir ~find_cache ~anchor @@ Filename.dirname filepath - in - root, Option.map (fun path -> path @ [basename]) path_opt + if FilePath.has_ext suffix filepath then + E.fatalf `InvalidLibrary "The file path %a does not have the suffix `%s'" FilePath.pp filepath suffix; + let filepath = FilePath.rem_ext filepath in + let root, path_opt = + load_from_dir ~version ~find_cache ~anchor (FilePath.parent filepath) + in + root, Option.map (fun path -> UnitPath.add_seg path (FilePath.basename filepath)) path_opt let root lib = lib.root let iter_routes f lib = Anchor.iter_routes f lib.loaded_anchor -let dispatch_path ~depth local ~global (lib : t) (path : path) = +let dispatch_path ~depth local ~global (lib : t) (path : UnitPath.t) = + E.tracef "Library.dispatch_path" @@ fun () -> match Anchor.dispatch_path lib.loaded_anchor path with | None -> local lib path - | Some (router, router_argument, path) -> - global ~depth:(depth+1) ~router ~router_argument ~starting_dir:lib.root path + | Some (route, path) -> + global ~depth:(depth+1) ~lib_root:lib.root route path let resolve_local lib path ~suffix = - let src = "Library.resolve_local" in - match path with - | [] -> E.error_unit_not_found_msgf ~src "No unit at the root (%s)" lib.root - | path -> - if File.hijacking_anchors_exist ~anchor:lib.anchor ~root:lib.root path then - E.error_unit_not_found_msgf ~src - "The unit path %a does not belong to the library (%s) but a library at its subdirectory. \ - Check all the files named `%s' within the directory %s." - Util.pp_path path lib.root lib.anchor lib.root - else - ret (lib, path, File.join (lib.root :: path) ^ suffix) + E.tracef "Library.resolve_local" @@ fun () -> + if UnitPath.is_root path then E.fatalf `InvalidLibrary "Unit path is empty"; + match File.locate_hijacking_anchor ~anchor:lib.anchor ~root:lib.root path with + | Some anchor -> + E.fatalf `InvalidLibrary + "The unit `%a' does not belong to the library `%a' because `%a' exists" + UnitPath.pp path FilePath.pp lib.root FilePath.pp anchor + | None -> + lib, path, FilePath.add_ext suffix (FilePath.append_unit lib.root path) (** @param suffix The suffix should include the dot. *) let resolve ~depth = dispatch_path ~depth resolve_local diff --git a/src/manager/Library.mli b/src/manager/Library.mli index 796b5d8..38b38e1 100644 --- a/src/manager/Library.mli +++ b/src/manager/Library.mli @@ -2,30 +2,22 @@ open BantorraBasis (** {1 Types} *) -type path = Anchor.path -(** The type of unit paths. *) - type t (** The type of libraries. *) (** {1 Initialization} *) -val load_from_root : find_cache:(string -> t option) -> anchor:string -> File.filepath -> - (t, [> `InvalidLibrary of string ]) result +val load_from_root : version:string -> find_cache:(FilePath.t -> t option) -> anchor:string -> File.path -> t -val load_from_dir : find_cache:(string -> t option) -> anchor:string -> File.filepath -> - (t * path option, [> `InvalidLibrary of string ]) result +val load_from_dir : version:string -> find_cache:(FilePath.t -> t option) -> anchor:string -> File.path -> t * UnitPath.t option -val load_from_unit : find_cache:(string -> t option) -> anchor:string -> File.filepath -> suffix:string -> - (t * path option, [> `InvalidLibrary of string ]) result +val load_from_unit : version:string -> find_cache:(FilePath.t -> t option) -> anchor:string -> File.path -> suffix:string -> t * UnitPath.t option -(** {1 Accessor} *) +(** {1 Accessors} *) -val root : t -> File.filepath +val root : t -> File.path -val iter_routes : - (router:string -> router_argument:Marshal.value -> (unit, 'e) result) -> - t -> (unit, 'e) result +val iter_routes : (Router.route -> unit) -> t -> unit (** {1 Hook for Library Managers} *) @@ -35,10 +27,9 @@ val iter_routes : val resolve : depth:int -> global:(depth:int -> - router:string -> - router_argument:Marshal.value -> - starting_dir:File.filepath -> - path -> + lib_root:File.path -> + Router.route -> + UnitPath.t -> suffix:string -> - (t * path * File.filepath, [> `UnitNotFound of string] as 'e) result) -> - t -> path -> suffix:string -> (t * path * File.filepath, 'e) result + t * UnitPath.t * File.path) -> + t -> UnitPath.t -> suffix:string -> t * UnitPath.t * File.path diff --git a/src/manager/Manager.ml b/src/manager/Manager.ml index e811936..6d20530 100644 --- a/src/manager/Manager.ml +++ b/src/manager/Manager.ml @@ -1,88 +1,54 @@ -module E = Errors open BantorraBasis -open ResultMonad.Syntax +module E = Error type t = - { anchor : string - ; routers : (string, Router.t) Hashtbl.t - ; loaded_libs : (string, Library.t) Hashtbl.t + { version : string + ; anchor : string + ; router : Router.t + ; loaded_libs : (FilePath.t, Library.t) Hashtbl.t } +type path = UnitPath.t type library = Library.t -type path = Anchor.path -let check_dep routers root = - let src = "Manager.check_dep" in - Library.iter_routes @@ fun ~router ~router_argument -> - match Hashtbl.find_opt routers router with - | None -> E.error_invalid_library_msgf ~src "Could not find the router named `%s'" router - | Some r -> - if Router.fast_check r ~starting_dir:root ~arg:router_argument then - ret () - else - E.error_invalid_library_msgf ~src - "The fast checking failed for the route with router = `%s' and router_argument = `%a'" - router Marshal.dump router_argument - -let init ~anchor ~routers = - let src = "Manager.init" in - match Util.Hashtbl.of_unique_seq @@ List.to_seq routers with - | Error (`DuplicateKeys key) -> - E.error_invalid_router_msgf ~src "Multiple routers named %s" key - | Ok routers -> - let loaded_libs = Hashtbl.create 10 in - ret {anchor; routers; loaded_libs} +let init ~version ~anchor router = + let loaded_libs = Hashtbl.create 10 in + {version; anchor; router; loaded_libs} let find_cache lm = Hashtbl.find_opt lm.loaded_libs -let check_and_cache_library lm lib = +let cache_library lm lib = let lib_root = Library.root lib in - let* () = check_dep lm.routers lib_root lib in - Hashtbl.replace lm.loaded_libs lib_root lib; - ret () + Hashtbl.replace lm.loaded_libs lib_root lib let load_library_from_root lm lib_root = - let* lib = Library.load_from_root ~find_cache:(find_cache lm) ~anchor:lm.anchor lib_root in - let* () = check_and_cache_library lm lib in - ret lib + let lib = Library.load_from_root ~version:lm.version ~find_cache:(find_cache lm) ~anchor:lm.anchor lib_root in + cache_library lm lib; lib -let load_library_from_route lm ~router ~router_argument ~starting_dir = - let src = "Manager.load_library_from_route" in - match Hashtbl.find_opt lm.routers router with - | None -> E.error_invalid_library_msgf ~src "Router `%s' not found" router - | Some loaded_router -> - let* lib_root = Router.route loaded_router ~starting_dir ~arg:router_argument in - load_library_from_root lm lib_root +let load_library_from_route ?hop_limit lm ~lib_root route = + let lib_root = lm.router ?hop_limit ~lib_root route in + load_library_from_root lm lib_root -let load_library_from_route_with_cwd lm ~router ~router_argument = - load_library_from_route lm ~router_argument ~router ~starting_dir:(File.getcwd ()) +let load_library_from_route_with_cwd ?hop_limit lm route = + load_library_from_route lm ?hop_limit ~lib_root:(File.get_cwd ()) route let load_library_from_dir lm dir = - let* lib, path_opt = Library.load_from_dir ~find_cache:(find_cache lm) ~anchor:lm.anchor dir in - let* () = check_and_cache_library lm lib in - ret (lib, path_opt) + let lib, path_opt = Library.load_from_dir ~version:lm.version ~find_cache:(find_cache lm) ~anchor:lm.anchor dir in + cache_library lm lib; lib, path_opt let load_library_from_cwd lm = - load_library_from_dir lm @@ File.getcwd () + load_library_from_dir lm @@ File.get_cwd () let load_library_from_unit lm filepath ~suffix = - let* lib, path_opt = Library.load_from_unit ~find_cache:(find_cache lm) ~anchor:lm.anchor filepath ~suffix in - let* () = check_and_cache_library lm lib in - ret (lib, path_opt) + let lib, path_opt = Library.load_from_unit ~version:lm.version ~find_cache:(find_cache lm) ~anchor:lm.anchor filepath ~suffix in + cache_library lm lib; lib, path_opt let resolve lm ?(max_depth=100) = - let src = "Manager.resolve" in - let rec global ~depth ~router ~router_argument ~starting_dir path ~suffix = + let rec global ~depth ~lib_root route path ~suffix = + E.tracef "Resolving library via route %a" (Json_repr.pp (module Json_repr.Ezjsonm)) route @@ fun () -> if depth > max_depth then - E.error_unit_not_found_msgf ~src "Library resolution stack overflow (max depth = %i)." max_depth + E.fatalf `InvalidLibrary "Library resolution stack overflow (max depth = %i)." max_depth else - match - let* lib = load_library_from_route lm ~starting_dir ~router ~router_argument in - Library.resolve ~depth ~global lib path ~suffix - with - | Error (`UnitNotFound msg | `InvalidLibrary msg) -> - E.append_error_unit_not_found_msgf ~earlier:msg ~src - "Could not find %a via the route with router = `%s' and router_argument = `%a'" - Util.pp_path path router Marshal.dump router_argument - | Ok res -> ret res + let lib = load_library_from_route lm ~lib_root route in + Library.resolve ~depth ~global lib path ~suffix in Library.resolve ~depth:0 ~global diff --git a/src/manager/Manager.mli b/src/manager/Manager.mli index 3ab1976..9a24ae0 100644 --- a/src/manager/Manager.mli +++ b/src/manager/Manager.mli @@ -8,14 +8,15 @@ type t type library (** The abstract type of libraries. *) -type path = string list +type path = UnitPath.t (** The type of unit paths. *) (** {1 Initialization} *) -val init : anchor:string -> routers:(string * Router.t) list -> (t, [> `InvalidRouter of string]) result +val init : version:string -> anchor:string -> Router.t -> t (** [init ~anchor ~routers] initiates a library manager for loading libraries. + @param version Versioning of the router. @param anchor The file name of the anchors. @param routers An association list as a mapping from router names to available routers. See {!module:Router}. *) @@ -24,7 +25,7 @@ val init : anchor:string -> routers:(string * Router.t) list -> (t, [> `InvalidR (** A library is identified by a JSON file in its root directory, which is called "anchor". *) -val load_library_from_root : t -> File.filepath -> (library, [> `InvalidLibrary of string ]) result +val load_library_from_root : t -> File.path -> library (** [load_library_from_root manager lib_root] loads the library at the directory [lib_root] from the file system. It is assumed that there is an anchor file is right at [lib_root]. @@ -33,47 +34,38 @@ val load_library_from_root : t -> File.filepath -> (library, [> `InvalidLibrary @return The loaded library. *) -val load_library_from_route : t -> - router:string -> - router_argument:Marshal.value -> - starting_dir:File.filepath -> - (library, [> `InvalidLibrary of string ]) result -(** [load_library_from_root ~router ~router_argument ~starting_dir] loads the library that the router - [router] is returning with the argument [router_argument] starting at [starting_dir]. +val load_library_from_route : ?hop_limit:int -> t -> lib_root:File.path -> Router.route -> library +(** [load_library_from_root manager ~lib_root route] loads the library by following the [route] + from the current library at [lib_root]. @param manager The library manager. - @param router The name of the router. - @param router_argument The argument sent to the router, as a JSON value. - @param starting_dir The starting directory, which is used by some routers ({i e.g.}, the {{:../../BantorraRouters/Waypoint/index.html}Waypoint} routers). + @param lib_root The starting directory, which is used by some routers ({i e.g.}, the {{:../../BantorraRouters/Waypoint/index.html}Waypoint} routers). + @param route The route specification, as a JSON value. @return The loaded library. *) -val load_library_from_route_with_cwd : t -> - router:string -> - router_argument:Marshal.value -> - (library, [> `InvalidLibrary of string ]) result -(** [load_library_from_root ~router ~router_argument] is the same as - {!val load_library_from_route}[~router ~router_argument ~starting_dir] - with [starting_dir] being the current working director. +val load_library_from_route_with_cwd : ?hop_limit:int -> t -> Router.route -> library +(** [load_library_from_root manager route] is + {!val load_library_from_route}[manager ~lib_root route] + with [lib_root] being the current working director. *) -val load_library_from_dir : t -> File.filepath -> (library * path option, [> `InvalidLibrary of string ]) result +val load_library_from_dir : t -> File.path -> library * path option (** [load_library_from_dir manager dir] assumes the directory [dir] resides in some library and will try to find the root of the library by locating the anchor file. It then loads the library marked by the anchor. @param manager The library manager. @param dir A directory that is assumed to be inside some library. - @return The loaded library. + @return The loaded library and the unit path *) -val load_library_from_cwd : t -> (library * path option, [> `InvalidLibrary of string ]) result -(** [load_library_from_cwd manager] is the same as {!val load_library_from_dir}[dir] with [dir] - being the current working director. +val load_library_from_cwd : t -> library * path option +(** [load_library_from_cwd manager] is {!val load_library_from_dir}[manager dir] + with [dir] being the current working director. *) -val load_library_from_unit : t -> File.filepath -> suffix:string -> - (library * path option, [> `InvalidLibrary of string ]) result +val load_library_from_unit : t -> File.path -> suffix:string -> library * path option (** [locate_anchor_from_unit filepath ~suffix] assumes [filepath] ends with [suffix] and the file at [filepath] resides in some library. It will try to find the root of the library and load the library. @@ -90,9 +82,8 @@ val load_library_from_unit : t -> File.filepath -> suffix:string -> *) val resolve : - t -> ?max_depth:int -> library -> path -> suffix:string -> - (library * path * File.filepath, [ `InvalidLibrary of string | `UnitNotFound of string ]) result -(** [resolve manager lib path ~suffix] resolves [path] in the library in the library [lib] and returns the {i eventual} library where the unit belongs and the corresponding file path with the specified suffix. + t -> ?max_depth:int -> library -> path -> suffix:string -> library * path * File.path +(** [resolve manager lib path ~suffix] resolves [path] in the library in the library [lib] and returns the {e eventual} library where the unit belongs and the corresponding file path with the specified suffix. @param manager The library manager. @param max_depth Maximum depth for resolving recursive library mounting. The default value is [100]. diff --git a/src/manager/Router.ml b/src/manager/Router.ml index dd6c128..22c8ba8 100644 --- a/src/manager/Router.ml +++ b/src/manager/Router.ml @@ -1,18 +1,14 @@ -module E = Errors open BantorraBasis +module E = Error -type argument = Marshal.value -type t = - { fast_checker: starting_dir:File.filepath -> arg:argument -> bool - ; router: starting_dir:File.filepath -> arg:argument -> (File.filepath, [`InvalidLibrary of string]) result - } +type route = Json_repr.ezjsonm +type t = ?hop_limit:int -> lib_root:File.path -> route -> File.path -let make ?fast_checker router = - let fast_checker = Option.value fast_checker - ~default:(fun ~starting_dir ~arg -> Result.is_ok @@ router ~starting_dir ~arg) +let fix (f : t -> t) ?hop_limit ~lib_root route = + let rec go ?(hop_limit=10) ~lib_root route = + if hop_limit <= 0 then + E.fatalf `InvalidLibrary "Exceeded hop limit (%d)" hop_limit + else + f go ~hop_limit:(hop_limit-1) ~lib_root route in - {fast_checker; router} - -let route {router; _} ~starting_dir ~arg = - E.open_error_invalid_library @@ router ~starting_dir ~arg -let fast_check {fast_checker; _} = fast_checker + f go ?hop_limit ~lib_root route diff --git a/src/manager/Router.mli b/src/manager/Router.mli index 2aab397..c9918fa 100644 --- a/src/manager/Router.mli +++ b/src/manager/Router.mli @@ -2,25 +2,12 @@ open BantorraBasis (** {1 Types} *) -type t -(** The type of library routers. *) - -type argument = Marshal.value +type route = Json_repr.ezjsonm (** The type of arguments to routers. *) -(** {1 The builder} *) - -val make : - ?fast_checker:(starting_dir:string -> arg:argument -> bool) -> - (starting_dir:string -> arg:argument -> (File.filepath, [`InvalidLibrary of string]) result) -> - t -(** [make ?fast_checker route] creates a new router that can be used in {!val:Manager.init}. - - @param route [route ~starting_dir ~arg] is responsible for finding the root of the library specified by [arg]. A library manager will feed the router with unparsed [router_argument] field in an anchor file as [arg] and the root of the mounting library as [starting_dir]. (See {!module:Manager}.) - @param fast_checker A validity checker for dependencies in anchor files when loading a library (before the units from other libraries are actually needed). It is taking the same arguments as the [router] does, but it only needs to check whether the resolution could have been successful. Some library resolution is expensive (e.g., involving downloading the sources from the server) and a faster, incomplete validity checker might be desirable. If absent, [route] will be used as the checker. -*) +type t = ?hop_limit:int -> lib_root:File.path -> route -> File.path +(** The type of library routers. *) -(** {1 Accessors} *) +(** {1 Combinators} *) -val route : t -> starting_dir:string -> arg:argument -> (File.filepath, [> `InvalidLibrary of string]) result -val fast_check : t -> starting_dir:string -> arg:argument -> bool +val fix : (t -> t) -> t diff --git a/src/manager/Trie.ml b/src/manager/Trie.ml new file mode 100644 index 0000000..43bafc3 --- /dev/null +++ b/src/manager/Trie.ml @@ -0,0 +1,59 @@ +open BantorraBasis + +module StringMap = Map.Make(String) + +type 'a node = + { root : 'a option + ; children : 'a node StringMap.t + } +type 'a t = 'a node option + +let empty : 'a t = None + +let root_node d : _ node = + { root = Some d; children = StringMap.empty } + +let rec singleton_node p d = + match p with + | [] -> root_node d + | seg::p -> + { root = None; children = StringMap.singleton seg (singleton_node p d) } + +let singleton_ p d = Some (singleton_node p d) + +let singleton p d = singleton_ (UnitPath.to_list p) d + +let add p d = + let exception DuplicateUnitPath in + let rec go_node p d n = + match p with + | [] -> begin match n.root with None -> {n with root = Some d} | _ -> raise DuplicateUnitPath end + | seg::p -> {n with children = StringMap.update seg (go p d) n.children} + and go p d = + function + | None -> singleton_ p d + | Some n -> Some (go_node p d n) + in + try go (UnitPath.to_list p) d + with DuplicateUnitPath -> Error.fatalf `JSONFormat "Multiple libraries mounted at %a" UnitPath.pp p + +let rec find_node p n = + match + match p with + | [] -> None + | seg::p -> find_ p (StringMap.find_opt seg n.children) + with + | None -> Option.map (fun d -> d, UnitPath.unsafe_of_list p) n.root + | Some ans -> Some ans +and find_ p = + function + | None -> None + | Some n -> find_node p n + +let find p t = find_ (UnitPath.to_list p) t + +let rec iter_values_node f {root; children} = + Option.iter f root; + StringMap.iter (fun _ -> iter_values_node f) children + +let iter_values f m = Option.iter (iter_values_node f) m diff --git a/src/manager/Trie.mli b/src/manager/Trie.mli new file mode 100644 index 0000000..8382fdf --- /dev/null +++ b/src/manager/Trie.mli @@ -0,0 +1,9 @@ +open BantorraBasis + +type +!'a t + +val empty : 'a t +val singleton : UnitPath.t -> 'a -> 'a t +val add : UnitPath.t -> 'a -> 'a t -> 'a t +val find : UnitPath.t -> 'a t -> ('a * UnitPath.t) option +val iter_values : ('a -> unit) -> 'a t -> unit diff --git a/src/manager/dune b/src/manager/dune index 433cafa..34447c8 100644 --- a/src/manager/dune +++ b/src/manager/dune @@ -1,4 +1,4 @@ (library (name Bantorra) (public_name bantorra) - (libraries bantorra.basis)) + (libraries json-data-encoding bantorra.basis))