├── docs ├── dune └── index.mld ├── test ├── lib │ └── number │ │ └── anchor.json ├── dune ├── anchor.json └── Example.ml ├── dune-project ├── src ├── internal │ ├── Git.mli │ ├── Trie.mli │ ├── Table.mli │ ├── Anchor.mli │ ├── Anchor.ml │ ├── Library.mli │ ├── Table.ml │ ├── Trie.ml │ ├── Library.ml │ └── Git.ml ├── Bantorra.ml ├── dune ├── Bantorra.mli ├── Web.mli ├── Web.ml ├── UnitPath.mli ├── Marshal.mli ├── FilePath.mli ├── UnitPath.ml ├── Marshal.ml ├── FilePath.ml ├── File.mli ├── Reporter.ml ├── Manager.ml ├── Router.ml ├── Manager.mli ├── Router.mli └── File.ml ├── .github ├── dependabot.yaml └── workflows │ └── ocaml.yml ├── README.mkd ├── CONTRIBUTING.markdown ├── bantorra.opam ├── .gitignore └── LICENSE /docs/dune: -------------------------------------------------------------------------------- 1 | (documentation) 2 | -------------------------------------------------------------------------------- /test/lib/number/anchor.json: -------------------------------------------------------------------------------- 1 | { 2 | "format": "1.0.0" 3 | } 4 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name Example) 3 | (libraries asai bantorra)) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.5) 2 | (name bantorra) 3 | (formatting disabled) 4 | -------------------------------------------------------------------------------- /src/internal/Git.mli: -------------------------------------------------------------------------------- 1 | val route : ?err_on_failed_fetch:bool -> FilePath.t -> Marshal.value -> FilePath.t 2 | -------------------------------------------------------------------------------- /test/anchor.json: -------------------------------------------------------------------------------- 1 | { 2 | "format": "1.0.0", 3 | "mounts": { "std/num": ["file", "./lib/number"] } 4 | } 5 | -------------------------------------------------------------------------------- /.github/dependabot.yaml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | -------------------------------------------------------------------------------- /src/Bantorra.ml: -------------------------------------------------------------------------------- 1 | module Manager = Manager 2 | module Router = Router 3 | module Reporter = Reporter 4 | module UnitPath = UnitPath 5 | module FilePath = FilePath 6 | module File = File 7 | module Web = Web 8 | module Marshal = Marshal 9 | -------------------------------------------------------------------------------- /src/internal/Trie.mli: -------------------------------------------------------------------------------- 1 | type +!'a t 2 | 3 | val empty : 'a t 4 | val singleton : UnitPath.t -> 'a -> 'a t 5 | val add : UnitPath.t -> 'a -> 'a t -> 'a t 6 | val find : UnitPath.t -> 'a t -> ('a * UnitPath.t) option 7 | val iter_values : ('a -> unit) -> 'a t -> unit 8 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Bantorra) 3 | (public_name bantorra) 4 | (libraries 5 | algaeff 6 | asai 7 | bos 8 | bwd 9 | curly 10 | ezjsonm 11 | findlib 12 | fpath 13 | json-data-encoding 14 | unix 15 | )) 16 | 17 | (include_subdirs unqualified) 18 | -------------------------------------------------------------------------------- /src/internal/Table.mli: -------------------------------------------------------------------------------- 1 | type t = (Marshal.value, Marshal.value) Hashtbl.t 2 | 3 | val lookup : t -> Marshal.value -> Marshal.value option 4 | 5 | val parse : version:string -> string -> t 6 | 7 | val read : version:string -> FilePath.t -> t 8 | 9 | val get_web : version:string -> string -> t 10 | 11 | val write : version:string -> FilePath.t -> t -> unit 12 | -------------------------------------------------------------------------------- /src/Bantorra.mli: -------------------------------------------------------------------------------- 1 | (** The bantorra library manager. *) 2 | 3 | (** {1 Main Modules} *) 4 | 5 | module Manager = Manager 6 | 7 | module Router = Router 8 | 9 | module Reporter : Asai.MinimumSigs.Reporter 10 | 11 | (** {1 Helper Modules} *) 12 | 13 | module UnitPath = UnitPath 14 | (** Unit paths. *) 15 | 16 | module FilePath = FilePath 17 | 18 | module File = File 19 | 20 | module Web = Web 21 | 22 | module Marshal = Marshal 23 | (** JSON Serialization. *) 24 | -------------------------------------------------------------------------------- /src/Web.mli: -------------------------------------------------------------------------------- 1 | (** Web utility functions. *) 2 | 3 | val get : ?follow_redirects:bool -> string -> string 4 | (** [get url] returns the body of the response of HTTP GET at [url]. 5 | 6 | @param follow_redirects Whether to follow redirections such as HTTP 301 and 203. [true] by default. 7 | *) 8 | 9 | val is_online : unit -> bool 10 | (** Check connectivity using Firefox's detection of captive portals. See {:https://firefox-source-docs.mozilla.org/networking/captive_portals.html}. *) 11 | -------------------------------------------------------------------------------- /README.mkd: -------------------------------------------------------------------------------- 1 | # 📚 bantorra: Library Management 🔖 2 | 3 | _bantorra_ is an OCaml package for loading user libraries and resolving unit paths into file paths. The design is informed by proof assistants based on dependent type theory, where it is common to work with source code directly. Check out the [project website](https://RedPRL.org/bantorra/bantorra) for more information. 4 | 5 | ## Installation 6 | 7 | You need OCaml 5.0 or newer. You can check out the source repository and install the latest version in development: 8 | ``` 9 | git clone https://github.com/RedPRL/bantorra.git 10 | opam install ./bantorra 11 | ``` 12 | -------------------------------------------------------------------------------- /.github/workflows/ocaml.yml: -------------------------------------------------------------------------------- 1 | name: Build, test, and doc update 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | jobs: 8 | run: 9 | strategy: 10 | matrix: 11 | include: 12 | - ocaml-compiler: "ocaml-base-compiler.5.1.0" 13 | with-doc: true 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v4 17 | - uses: RedPRL/actions-ocaml@v2 18 | with: 19 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 20 | with-doc: ${{ matrix.with-doc }} 21 | publish-doc-if-built: ${{ github.ref == 'refs/heads/main' }} 22 | -------------------------------------------------------------------------------- /src/internal/Anchor.mli: -------------------------------------------------------------------------------- 1 | (** {1 Types} *) 2 | 3 | type t 4 | (** The type of anchors. *) 5 | 6 | (** {1 Anchor I/O} *) 7 | 8 | val read : version:string -> premount:Router.param Trie.t -> FilePath.t -> t 9 | (** [read path] read the content of an anchor file. *) 10 | 11 | (** {1 Accessors} *) 12 | 13 | val dispatch_path : t -> UnitPath.t -> (Router.param * UnitPath.t) option 14 | (** [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. *) 15 | 16 | val path_is_local : t -> UnitPath.t -> bool 17 | -------------------------------------------------------------------------------- /src/Web.ml: -------------------------------------------------------------------------------- 1 | let get ?(follow_redirects=true) url = 2 | let args = if follow_redirects then ["-L"] else [] in 3 | Reporter.tracef "when reading content from `%s'" url @@ fun () -> 4 | match Curly.get ~args url with 5 | | Ok {code = 200; body; _} -> body 6 | | Ok {code; _} -> Reporter.fatalf WebError "got@ HTTP@ code@ %d,@ which@ is@ not@ 200" code 7 | | Error err -> Reporter.fatalf WebError "%a" Curly.Error.pp err 8 | 9 | (* See https://firefox-source-docs.mozilla.org/networking/captive_portals.html *) 10 | let online = 11 | lazy begin 12 | Reporter.try_with ~emit:(fun _ -> ()) ~fatal:(fun _ -> false) @@ fun () -> 13 | String.equal 14 | (get "http://detectportal.firefox.com/canonical.html") 15 | "" 16 | end 17 | 18 | let is_online () = Lazy.force online 19 | -------------------------------------------------------------------------------- /src/internal/Anchor.ml: -------------------------------------------------------------------------------- 1 | module J = Json_encoding 2 | 3 | type t = { mounts : Router.param Trie.t } 4 | 5 | module Json = 6 | struct 7 | let format v = J.req ~title:"format version" ~description:"format version of the anchor file" "format" (J.constant v) 8 | (* let source_dir = J.dft ~title:"Source directory" ~description:"source directory (default: \"./\")" "source_dir" J.string "./" *) 9 | let mounts = J.dft ~title:"library mounts" ~description:"list of library mounts" "mounts" (J.assoc J.any_ezjson_value) [] 10 | let anchor v = J.obj2 (format v) mounts 11 | end 12 | 13 | let read ~version ~premount path : t = 14 | let (), routes = Marshal.read (Json.anchor version) path in 15 | let mounts = List.fold_right (fun (path, route) -> Trie.add (UnitPath.of_string path) route) routes premount in 16 | { mounts } 17 | 18 | let dispatch_path {mounts; _} path = Trie.find path mounts 19 | 20 | let path_is_local anchor path = 21 | Option.is_none @@ dispatch_path anchor path 22 | -------------------------------------------------------------------------------- /src/UnitPath.mli: -------------------------------------------------------------------------------- 1 | (** Unit paths. *) 2 | 3 | (** {1 Type} *) 4 | 5 | type t 6 | 7 | (** {1 Comparison} *) 8 | 9 | val equal : t -> t -> bool 10 | val compare : t -> t -> int 11 | 12 | (** {1 Root} *) 13 | 14 | val root : t 15 | val is_root : t -> bool 16 | 17 | (** {1 Segments} *) 18 | 19 | val is_seg : string -> bool 20 | (** [is_seg d] checks whether [d] is a valid segment, which means [d] is a valid directory name and is not [.] or [..]. *) 21 | 22 | val of_seg : string -> t 23 | val add_seg : t -> string -> t 24 | val prepend_seg : string -> t -> t 25 | 26 | (** {1 Conversion to/from lists} *) 27 | 28 | val to_list : t -> string list 29 | val of_list : string list -> t 30 | 31 | (** {1 Conversion to/from strings} *) 32 | 33 | val of_string : ?allow_ending_slash:bool -> ?allow_extra_dots:bool -> string -> t 34 | val to_string : t -> string 35 | 36 | (** {1 Pretty printer} *) 37 | 38 | val pp : Format.formatter -> t -> unit 39 | 40 | (**/**) 41 | 42 | val unsafe_of_list : string list -> t 43 | -------------------------------------------------------------------------------- /src/Marshal.mli: -------------------------------------------------------------------------------- 1 | (** {1 Serialization} *) 2 | 3 | type value = Json_repr.ezjsonm 4 | (** Type of JSON values. *) 5 | 6 | val normalize : value -> value 7 | (** Sort properties of objects by keys, raising errors on duplicate keys. *) 8 | 9 | val destruct : 'a Json_encoding.encoding -> value -> 'a 10 | (** [parse str] destructs a JSON value. *) 11 | 12 | val parse : 'a Json_encoding.encoding -> string -> 'a 13 | (** [parse str] parses the string [str]. *) 14 | 15 | val read : 'a Json_encoding.encoding -> FilePath.t -> 'a 16 | (** [read enc path] reads and parses the content of the file at [path]. *) 17 | 18 | val read_url : 'a Json_encoding.encoding -> string -> 'a 19 | (** [read_url enc url] fetches and parses the JSON content at [url] via HTTP Get. *) 20 | 21 | val write : ?minify:bool -> 'a Json_encoding.encoding -> FilePath.t -> 'a -> unit 22 | (** [write enc path v] writes the serialization of [v] into the file at [path]. *) 23 | 24 | val to_string : value -> string 25 | (** [to_string json] serializes [json] into a compact, minified string. *) 26 | -------------------------------------------------------------------------------- /CONTRIBUTING.markdown: -------------------------------------------------------------------------------- 1 | # Copyright Assignment 2 | 3 | Thank you for your contribution. Here is some important legal stuff. 4 | 5 | By submitting a pull request for this project, unless explicitly stated otherwise, you agree to assign your copyright of the contribution to **The RedPRL Development Team** when it is accepted (merged with or without minor changes). You assert that you have full power to assign the copyright, and that any copyright owned by or shared with a third party has been clearly marked with appropriate copyright notices. If you are employed, please check with your employer about the ownership of your contribution. 6 | 7 | This would allow us to, for example, change the license of the codebase to [Mozilla Public License (MPL) 2.0](https://www.mozilla.org/en-US/MPL/2.0/FAQ/) or transfer the ownership of the project to someone else *without your further consent*. We demand this assignment so that we do not have to ask *everyone* who has ever contributed for these activities. This requires trust, and if you feel uncomfortable about this assignment, please make an explicit note. 8 | -------------------------------------------------------------------------------- /bantorra.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bantorra" 3 | synopsis: "Extensible Library Management and Path Resolution" 4 | description: """ 5 | Managing libraries and resolving unit paths within them. 6 | """ 7 | maintainer: ["favonia "] 8 | authors: ["The RedPRL Development Team"] 9 | license: "Apache-2.0 WITH LLVM-exception" 10 | homepage: "https://github.com/RedPRL/bantorra" 11 | bug-reports: "https://github.com/RedPRL/bantorra/issues" 12 | dev-repo: "git+https://github.com/RedPRL/bantorra.git" 13 | depends: [ 14 | "dune" {>= "2.0"} 15 | "ocaml" {>= "5.1"} 16 | "asai" {>= "0.1"} 17 | "algaeff" {>= "0.2"} 18 | "bos" {>= "0.2"} 19 | "bwd" {>= "2.1"} 20 | "conf-git" {post} 21 | "curly" {>= "0.2"} 22 | "ezjsonm" {>= "1.2"} 23 | "json-data-encoding" {>= "0.9"} 24 | "ocamlfind" {>= "1.8"} 25 | "odoc" {with-doc} 26 | ] 27 | build: [ 28 | ["dune" "build" "-p" name "-j" jobs] 29 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 30 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 31 | ] 32 | depexts: [ 33 | ["git"] 34 | ] 35 | -------------------------------------------------------------------------------- /src/FilePath.mli: -------------------------------------------------------------------------------- 1 | (** Absolute file paths. *) 2 | 3 | (** The API mimics the [fpath] library, but with optional arguments [relative_to] and [expanding_tilde] 4 | to turn relative paths into absolute ones when needed. 5 | 6 | No functions in this module access the actual file systems. *) 7 | 8 | type t 9 | val equal : t -> t -> bool 10 | val compare : t -> t -> int 11 | val is_root : t -> bool 12 | val is_dir_path : t -> bool 13 | val to_dir_path : t -> t 14 | val parent : t -> t 15 | val basename : t -> string 16 | val has_ext : string -> t -> bool 17 | val add_ext : string -> t -> t 18 | val rem_ext : t -> t 19 | 20 | val add_unit_seg : t -> string -> t 21 | (** Append a unit segment to a file path. *) 22 | 23 | val append_unit : t -> UnitPath.t -> t 24 | (** Append a unit path to a file path. *) 25 | 26 | val of_fpath : ?relative_to:t -> ?expanding_tilde:t -> Fpath.t -> t 27 | val to_fpath : t -> Fpath.t 28 | val of_string : ?relative_to:t -> ?expanding_tilde:t -> string -> t 29 | val to_string : t -> string 30 | val pp : relative_to:t -> Format.formatter -> t -> unit 31 | 32 | val pp_abs : Format.formatter -> t -> unit 33 | (** An alias of [Fpath.pp]. *) 34 | -------------------------------------------------------------------------------- /src/internal/Library.mli: -------------------------------------------------------------------------------- 1 | (** {1 Types} *) 2 | 3 | type t 4 | (** The type of libraries. *) 5 | 6 | (** {1 Initialization} *) 7 | 8 | val load_from_root : version:string -> premount:Router.param Trie.t -> find_cache:(FilePath.t -> t option) -> anchor:string -> FilePath.t -> t 9 | 10 | val load_from_dir : version:string -> premount:Router.param Trie.t -> find_cache:(FilePath.t -> t option) -> anchor:string -> FilePath.t -> t * UnitPath.t option 11 | 12 | val load_from_unit : version:string -> premount:Router.param Trie.t -> find_cache:(FilePath.t -> t option) -> anchor:string -> FilePath.t -> suffix:string -> t * UnitPath.t option 13 | 14 | (** {1 Accessors} *) 15 | 16 | val root : t -> FilePath.t 17 | 18 | (** {1 Hook for Library Managers} *) 19 | 20 | (** The following API is for a library manager to chain all the libraries together. 21 | Please use the high-level API in {!module:Manager} instead. *) 22 | 23 | val resolve : 24 | depth:int -> 25 | global:(depth:int -> 26 | ?starting_dir:FilePath.t -> 27 | Router.param -> 28 | UnitPath.t -> 29 | suffix:string -> 30 | t * UnitPath.t * FilePath.t) -> 31 | t -> UnitPath.t -> suffix:string -> t * UnitPath.t * FilePath.t 32 | -------------------------------------------------------------------------------- /src/internal/Table.ml: -------------------------------------------------------------------------------- 1 | type t = (Marshal.value, Marshal.value) Hashtbl.t 2 | 3 | module Json = 4 | struct 5 | module J = Json_encoding 6 | let format v = J.req ~title:"format version" ~description:"format version of the configuration file" "format" (J.constant v) 7 | let replaced = J.any_ezjson_value 8 | let replacement = J.any_ezjson_value 9 | let entry = J.tup2 replaced replacement 10 | let table = J.dft ~title:"replace" ~description:"replacement table for routing parameters" "rewrite" (J.list entry) [] 11 | let config v = J.obj2 (format v) table 12 | end 13 | 14 | let parse ~version str : t = 15 | let (), l = Marshal.parse (Json.config version) str in 16 | let table = Hashtbl.create 0 in 17 | l |> List.iter (fun (key, value) -> 18 | let key = Marshal.normalize key in 19 | if Hashtbl.mem table key then 20 | Reporter.fatalf InvalidRouter "duplicate@ rewrite@ key@ `%s'" (Marshal.to_string key) 21 | else 22 | Hashtbl.replace table key value 23 | ); 24 | table 25 | 26 | let lookup tbl param = Hashtbl.find_opt tbl (Marshal.normalize param) 27 | 28 | let read ~version path : t = 29 | parse ~version @@ File.read path 30 | 31 | let get_web ~version url : t = 32 | parse ~version @@ Web.get url 33 | 34 | let write ~version path table = 35 | let l = List.of_seq @@ Hashtbl.to_seq table in 36 | Marshal.write ~minify:false (Json.config version) path ((), l) 37 | -------------------------------------------------------------------------------- /src/UnitPath.ml: -------------------------------------------------------------------------------- 1 | type t = string list (* all segments must be non-empty and satisfy Fpath.is_seg *) 2 | 3 | let equal = List.equal String.equal 4 | 5 | let compare = List.compare String.compare 6 | 7 | let root : t = [] 8 | 9 | let is_root l = l = root 10 | 11 | let is_seg s = s <> "" && Fpath.is_seg s && not (Fpath.is_rel_seg s) 12 | 13 | let assert_seg s = 14 | if not (is_seg s) then 15 | Reporter.fatalf IllFormedUnitPath "`%s'@ not@ a@ valid@ unit@ segment" (String.escaped s) 16 | 17 | let of_seg s = assert_seg s; [s] 18 | 19 | let add_seg u s = assert_seg s; u @ [s] 20 | 21 | let prepend_seg s u = assert_seg s; s :: u 22 | 23 | let to_list l = l 24 | 25 | let of_list l = List.iter assert_seg l; l 26 | 27 | let of_string ?(allow_ending_slash=false) ?(allow_extra_dots=false) p = 28 | Reporter.tracef "when@ parsing@ `%s'@ as@ a@ unit@ path" (String.escaped p) @@ fun () -> 29 | let p = 30 | if allow_ending_slash && String.ends_with ~suffix:"/" p then 31 | String.sub p 0 (String.length p - 1) 32 | else 33 | p 34 | in 35 | if p = "." then [] 36 | else 37 | let l = String.split_on_char '/' p in 38 | let l = if allow_extra_dots then List.filter (fun s -> s <> ".") l else l in 39 | of_list l 40 | 41 | let to_string = 42 | function 43 | | [] -> "." 44 | | l -> String.concat "/" l 45 | 46 | let pp fmt l = Format.pp_print_string fmt (to_string l) 47 | 48 | let unsafe_of_list l = l 49 | -------------------------------------------------------------------------------- /src/internal/Trie.ml: -------------------------------------------------------------------------------- 1 | module StringMap = Map.Make(String) 2 | 3 | type 'a node = 4 | { root : 'a option 5 | ; children : 'a node StringMap.t 6 | } 7 | type 'a t = 'a node option 8 | 9 | let empty : 'a t = None 10 | 11 | let root_node d : _ node = 12 | { root = Some d; children = StringMap.empty } 13 | 14 | let rec singleton_node p d = 15 | match p with 16 | | [] -> root_node d 17 | | seg::p -> 18 | { root = None; children = StringMap.singleton seg (singleton_node p d) } 19 | 20 | let singleton_ p d = Some (singleton_node p d) 21 | 22 | let singleton p d = singleton_ (UnitPath.to_list p) d 23 | 24 | let add p d = 25 | let exception DuplicateUnitPath in 26 | let rec go_node p d n = 27 | match p with 28 | | [] -> begin match n.root with None -> {n with root = Some d} | _ -> raise DuplicateUnitPath end 29 | | seg::p -> {n with children = StringMap.update seg (go p d) n.children} 30 | and go p d = 31 | function 32 | | None -> singleton_ p d 33 | | Some n -> Some (go_node p d n) 34 | in 35 | try go (UnitPath.to_list p) d 36 | with DuplicateUnitPath -> Reporter.fatalf IllFormedAnchor "multiple@ libraries@ mounted@ at@ `%a'" UnitPath.pp p 37 | 38 | let rec find_node p n = 39 | match 40 | match p with 41 | | [] -> None 42 | | seg::p -> find_ p (StringMap.find_opt seg n.children) 43 | with 44 | | None -> Option.map (fun d -> d, UnitPath.unsafe_of_list p) n.root 45 | | Some ans -> Some ans 46 | and find_ p = 47 | function 48 | | None -> None 49 | | Some n -> find_node p n 50 | 51 | let find p t = find_ (UnitPath.to_list p) t 52 | 53 | let rec iter_values_node f {root; children} = 54 | Option.iter f root; 55 | StringMap.iter (fun _ -> iter_values_node f) children 56 | 57 | let iter_values f m = Option.iter (iter_values_node f) m 58 | -------------------------------------------------------------------------------- /src/Marshal.ml: -------------------------------------------------------------------------------- 1 | type value = Json_repr.ezjsonm 2 | 3 | let rec find_duplicate_key = 4 | function 5 | | [] | [_] -> assert false 6 | | x1 :: x2 :: _ when String.equal (fst x1) (fst x2) -> fst x1 7 | | _ :: xs -> find_duplicate_key xs 8 | 9 | let rec normalize : value -> value = 10 | function 11 | | `O pairs -> 12 | let pairs = List.map (fun (p, v) -> p, normalize v) pairs in 13 | let sorted_uniq_pairs = List.sort_uniq (fun (key1, _) (key2, _) -> String.compare key1 key2) pairs in 14 | if List.length pairs <> List.length sorted_uniq_pairs then 15 | let sorted_pairs = List.sort (fun (key1, _) (key2, _) -> String.compare key1 key2) pairs in 16 | Reporter.fatalf IllFormedJSON "duplicate@ key@ `%s'" (find_duplicate_key sorted_pairs) 17 | else 18 | `O sorted_uniq_pairs 19 | | `A elems -> `A (List.map normalize elems) 20 | | (`Bool _ | `Float _ | `String _ | `Null) as j -> j 21 | 22 | let destruct enc json = 23 | try 24 | Json_encoding.destruct enc json 25 | with e -> 26 | Reporter.fatalf IllFormedJSON "%a" (Json_encoding.print_error ?print_unknown:None) e 27 | 28 | let construct enc data = 29 | try 30 | Json_encoding.construct enc data 31 | with e -> 32 | Reporter.fatalf IllFormedJSON "%a" (Json_encoding.print_error ?print_unknown:None) e 33 | 34 | let parse enc s = 35 | destruct enc @@ 36 | try Ezjsonm.value_from_string s with 37 | | Ezjsonm.Parse_error (_, msg) -> 38 | Reporter.fatal IllFormedJSON msg 39 | 40 | let read enc path = 41 | File.read path |> parse enc 42 | 43 | let read_url enc url = 44 | Web.get url |> parse enc 45 | 46 | let serialize ?(minify=true) enc data = 47 | data |> construct enc |> Ezjsonm.value_to_string ~minify 48 | 49 | let write ?(minify=false) enc path data = 50 | data |> serialize ~minify enc |> File.write path 51 | 52 | let to_string data = serialize ~minify:true Json_encoding.any_ezjson_value data 53 | -------------------------------------------------------------------------------- /src/FilePath.ml: -------------------------------------------------------------------------------- 1 | type t = Fpath.t (* must be an absolute, normalized path (no . or ..) *) 2 | 3 | let equal = Fpath.equal 4 | 5 | let compare = Fpath.compare 6 | 7 | let is_root = Fpath.is_root 8 | 9 | let is_dir_path = Fpath.is_dir_path 10 | 11 | let to_dir_path = Fpath.to_dir_path 12 | 13 | let parent = Fpath.parent 14 | 15 | let basename = Fpath.basename 16 | 17 | let has_ext = Fpath.has_ext 18 | 19 | let rem_ext ext = Fpath.rem_ext ext 20 | 21 | let add_ext = Fpath.add_ext 22 | 23 | let add_unit_seg p s = 24 | if not (UnitPath.is_seg s) then 25 | Reporter.fatalf IllFormedFilePath "`%s'@ not@ a@ valid@ unit@ segment" s; 26 | Fpath.add_seg p s 27 | 28 | let append_unit p u = 29 | if UnitPath.is_root u then p else 30 | Fpath.append p (Fpath.v @@ UnitPath.to_string u) 31 | 32 | let of_fpath ?relative_to ?expanding_tilde p = 33 | let p = 34 | match relative_to with 35 | | None -> p 36 | | Some relative_to -> Fpath.append relative_to p 37 | in 38 | let p = Fpath.normalize p in 39 | if Fpath.is_abs p then 40 | p 41 | else 42 | let p_str = Fpath.to_string p in 43 | if p_str == "~" || String.starts_with ~prefix:"~/" p_str then 44 | match expanding_tilde with 45 | | None -> Reporter.fatalf IllFormedFilePath "tilde@ expansion@ is@ not@ enabled@ for@ the@ file@ path@ `%a'" Fpath.pp p 46 | | Some home -> 47 | Fpath.v (Fpath.to_string home ^ String.sub p_str 1 (String.length p_str - 1)) 48 | else 49 | Reporter.fatalf IllFormedFilePath "file@ path@ `%a'@ is@ not@ an@ absolute@ path" Fpath.pp p 50 | 51 | let to_fpath p = p 52 | 53 | let of_string ?relative_to ?expanding_tilde p = 54 | Reporter.tracef "when@ parsing@ the@ file@ path@ `%s'" (String.escaped p) @@ fun () -> 55 | match Fpath.of_string p with 56 | | Error (`Msg msg) -> Reporter.fatal IllFormedFilePath msg 57 | | Ok p -> of_fpath ?relative_to ?expanding_tilde p 58 | 59 | let to_string = Fpath.to_string 60 | 61 | let pp_abs = Fpath.pp 62 | 63 | let pp ~relative_to fmt p = 64 | let p = 65 | match Fpath.relativize ~root:relative_to p with 66 | | None -> p 67 | | Some p -> p 68 | in 69 | Fpath.pp fmt p 70 | -------------------------------------------------------------------------------- /src/File.mli: -------------------------------------------------------------------------------- 1 | (** Basic I/O. *) 2 | 3 | (** {1 Path types} *) 4 | 5 | type path = FilePath.t 6 | 7 | (** {1 Basic I/O} *) 8 | 9 | val read : path -> string 10 | (** 11 | [read path] reads the content of string [str] the file at [path] (in binary mode). 12 | If there was already a file at [path], it will be overwritten. 13 | *) 14 | 15 | val write : path -> string -> unit 16 | (** 17 | [write path str] writes the string [str] the file at [path] (in binary mode). 18 | If there was already a file at [path], it will be overwritten. 19 | *) 20 | 21 | (** {1 Directories} *) 22 | 23 | val get_cwd : unit -> path 24 | (** 25 | [get_cwd ()] returns the current working directory. 26 | *) 27 | 28 | val ensure_dir : path -> unit 29 | (** 30 | [ensure_dir dir] effectively implements [mkdir -p dir] in OCaml. 31 | *) 32 | 33 | (** {1 Locating Files} *) 34 | 35 | val file_exists : path -> bool 36 | (** 37 | [file_exists file] checks whether [file] is a regular file. 38 | *) 39 | 40 | val locate_anchor : anchor:string -> path -> path * UnitPath.t 41 | (** 42 | [locate_anchor ~anchor dir] finds the closest regular file named [anchor] in [dir] or its ancestors in the file system tree. 43 | 44 | @param dir The starting directory. 45 | 46 | @return 47 | (1) the first directory that holds a regular file named [anchor] on the way from [dir] to the root directory; and (2) the relative path from the returned directory to [dir]. 48 | 49 | For example, on a typical Linux system, suppose there is no file called [anchor.txt] under directiors 50 | [/usr/lib/gcc/] and [/usr/lib/], but there is such a file under [/usr/]. 51 | [locate_anchor ~anchor:"anchor.txt" "/usr/lib/gcc"] will return ["/usr/", ["lib"; "gcc"]] 52 | and [locate_anchor ~anchor:"anchor.txt" "/usr/"] will return ["/usr/", []]. 53 | *) 54 | 55 | val locate_hijacking_anchor : anchor:string -> root:path -> UnitPath.t -> path option 56 | 57 | (** {1 Special Directories} *) 58 | 59 | val get_home : unit -> path 60 | 61 | val get_xdg_config_home : app_name:string -> path 62 | (** Get the per-user config directory based on [XDG_CONFIG_HOME] 63 | with reasonable default values on major platforms. *) 64 | 65 | val get_xdg_cache_home : app_name:string -> path 66 | (** Get the per-user persistent cache directory based on [XDG_CACHE_HOME] 67 | with reasonable default values on major platforms. *) 68 | 69 | val get_package_dir : string -> path 70 | -------------------------------------------------------------------------------- /src/Reporter.ml: -------------------------------------------------------------------------------- 1 | module Message = 2 | struct 3 | (** Type of error codes. See the asai documentation. *) 4 | type t = 5 | 6 | (* Errors from the system environment *) 7 | 8 | | SystemError (** Generic system errors. *) 9 | | MissingEnvironmentVariables (** Missing HOME or XDG_* environment variables. *) 10 | | FileError (** File paths are valid, but the files do not exist or file permissions are missing. *) 11 | | IllFormedFilePath (** File paths are ill-formed (independent of the file system state). *) 12 | | WebError (** All the network-related errors. *) 13 | | InvalidOCamlPackage (** Invalid OCaml package. *) 14 | 15 | (* Errors from parser *) 16 | 17 | | IllFormedJSON (** Low level JSON parsing errors. *) 18 | 19 | (* Errors about anchors *) 20 | 21 | | AnchorNotFound (** Could not find the anchor at the expected library location. *) 22 | | HijackingAnchor (** Having an anchor on the path to the expected anchor. *) 23 | | IllFormedAnchor (** The anchor itself is ill-formed. *) 24 | 25 | (* Errors about resolving *) 26 | 27 | | InvalidRouter (** The routing table itself is broken. *) 28 | | LibraryNotFound (** The routing table is okay, but the library cannot be found. *) 29 | | LibraryConflict (** Conflicting libraries are being loaded. *) 30 | | UnitNotFound (** Libraries are loaded, but the unit is not found. *) 31 | | IllFormedUnitPath (** The unit path is ill-formed. *) 32 | 33 | (** Default severity of error codes. See the asai documentation. *) 34 | let default_severity : t -> Asai.Diagnostic.severity = 35 | function 36 | | InvalidRouter -> Bug 37 | | _ -> Error 38 | 39 | (** String representation of error codes. See the asai documentation. *) 40 | let short_code : t -> string = 41 | function 42 | | SystemError -> "E0001" 43 | | MissingEnvironmentVariables -> "E0002" 44 | | IllFormedFilePath -> "E0003" 45 | | FileError -> "E0004" 46 | | WebError -> "E0005" 47 | | InvalidOCamlPackage -> "E0006" 48 | 49 | | IllFormedJSON -> "E0101" 50 | 51 | | AnchorNotFound -> "E0201" 52 | | HijackingAnchor -> "E0202" 53 | | IllFormedAnchor -> "E0203" 54 | 55 | | InvalidRouter -> "E0301" 56 | | LibraryNotFound -> "E0302" 57 | | LibraryConflict -> "E0303" 58 | | IllFormedUnitPath -> "E0304" 59 | | UnitNotFound -> "E0305" 60 | end 61 | 62 | include Asai.Reporter.Make(Message) 63 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | 3 | # -*- mode: gitignore; -*- 4 | *.install 5 | *~ 6 | \#*\# 7 | /.emacs.desktop 8 | /.emacs.desktop.lock 9 | *.elc 10 | auto-save-list 11 | tramp 12 | .\#* 13 | 14 | # Org-mode 15 | .org-id-locations 16 | *_archive 17 | 18 | # flymake-mode 19 | *_flymake.* 20 | 21 | # eshell files 22 | /eshell/history 23 | /eshell/lastdir 24 | 25 | # elpa packages 26 | /elpa/ 27 | 28 | # reftex files 29 | *.rel 30 | 31 | # AUCTeX auto folder 32 | auto/ 33 | 34 | # cask packages 35 | .cask/ 36 | dist/ 37 | 38 | # Flycheck 39 | flycheck_*.el 40 | 41 | # server auth directory 42 | /server/ 43 | 44 | # projectiles files 45 | .projectile 46 | 47 | # directory configuration 48 | .dir-locals.el 49 | 50 | 51 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 52 | 53 | *~ 54 | 55 | # temporary files which can be created if a process still has a handle open of a deleted file 56 | .fuse_hidden* 57 | 58 | # KDE directory preferences 59 | .directory 60 | 61 | # Linux trash folder which might appear on any partition or disk 62 | .Trash-* 63 | 64 | # .nfs files are created when an open file is removed but is still being accessed 65 | .nfs* 66 | 67 | 68 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 69 | 70 | # General 71 | .DS_Store 72 | .AppleDouble 73 | .LSOverride 74 | 75 | # Icon must end with two \r 76 | Icon 77 | 78 | 79 | # Thumbnails 80 | ._* 81 | 82 | # Files that might appear in the root of a volume 83 | .DocumentRevisions-V100 84 | .fseventsd 85 | .Spotlight-V100 86 | .TemporaryItems 87 | .Trashes 88 | .VolumeIcon.icns 89 | .com.apple.timemachine.donotpresent 90 | 91 | # Directories potentially created on remote AFP share 92 | .AppleDB 93 | .AppleDesktop 94 | Network Trash Folder 95 | Temporary Items 96 | .apdisk 97 | 98 | 99 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/OCaml.gitignore 100 | 101 | *.annot 102 | *.cmo 103 | *.cma 104 | *.cmi 105 | *.a 106 | *.o 107 | *.cmx 108 | *.cmxs 109 | *.cmxa 110 | 111 | # ocamlbuild working directory 112 | _build/ 113 | 114 | # ocamlbuild targets 115 | *.byte 116 | *.native 117 | 118 | # oasis generated files 119 | setup.data 120 | setup.log 121 | 122 | # Merlin configuring file for Vim and Emacs 123 | .merlin 124 | -------------------------------------------------------------------------------- /src/Manager.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { version : string 3 | ; anchor : string 4 | ; premount : Router.param Trie.t 5 | ; router : Router.t 6 | ; lock : Mutex.t 7 | ; loaded_libs : (FilePath.t, Library.t) Hashtbl.t 8 | } 9 | type path = UnitPath.t 10 | type library = Library.t 11 | 12 | let init ~version ~anchor ?(premount=Trie.empty) router = 13 | let loaded_libs = Hashtbl.create 10 in 14 | {version; anchor; premount; router; lock = Mutex.create (); loaded_libs} 15 | 16 | let find_cache lm = Hashtbl.find_opt lm.loaded_libs 17 | 18 | let cache_library lm lib = 19 | let lib_root = Library.root lib in 20 | Hashtbl.replace lm.loaded_libs lib_root lib 21 | 22 | let load_library_from_root lm lib_root = 23 | Mutex.protect lm.lock @@ fun () -> 24 | let lib = Library.load_from_root ~version:lm.version ~premount:lm.premount ~find_cache:(find_cache lm) ~anchor:lm.anchor lib_root in 25 | cache_library lm lib; lib 26 | 27 | let load_library_from_route lm ?starting_dir route = 28 | let lib_root = Router.run ~version:lm.version ?starting_dir @@ fun () -> lm.router route in 29 | load_library_from_root lm lib_root 30 | 31 | let load_library_from_route_with_cwd lm route = 32 | load_library_from_route lm ~starting_dir:(File.get_cwd ()) route 33 | 34 | let load_library_from_dir lm dir = 35 | Mutex.protect lm.lock @@ fun () -> 36 | let lib, path_opt = Library.load_from_dir ~version:lm.version ~premount:lm.premount ~find_cache:(find_cache lm) ~anchor:lm.anchor dir in 37 | cache_library lm lib; lib, path_opt 38 | 39 | let load_library_from_cwd lm = 40 | load_library_from_dir lm @@ File.get_cwd () 41 | 42 | let load_library_from_unit lm filepath ~suffix = 43 | Mutex.protect lm.lock @@ fun () -> 44 | let lib, path_opt = Library.load_from_unit ~version:lm.version ~premount:lm.premount ~find_cache:(find_cache lm) ~anchor:lm.anchor filepath ~suffix in 45 | cache_library lm lib; lib, path_opt 46 | 47 | let library_root = Library.root 48 | 49 | let resolve lm ?(max_depth=255) = 50 | let rec global ~depth ?starting_dir route path ~suffix = 51 | Reporter.tracef "@[<2>@[when@ resolving@ library@ via@ the@ route:@]@ @[%a@]@]" (Json_repr.pp (module Json_repr.Ezjsonm)) route @@ fun () -> 52 | if depth > max_depth then 53 | Reporter.fatalf LibraryNotFound "library@ resolution@ stack@ overflow@ (max depth = %i)" max_depth 54 | else 55 | let lib = load_library_from_route lm ?starting_dir route in 56 | Library.resolve ~depth ~global lib path ~suffix 57 | in 58 | Library.resolve ~depth:0 ~global 59 | -------------------------------------------------------------------------------- /src/Router.ml: -------------------------------------------------------------------------------- 1 | type param = Json_repr.ezjsonm 2 | type t = param -> FilePath.t 3 | type pipe = param -> param 4 | 5 | type env = {version : string; starting_dir : FilePath.t option} 6 | module Eff = Algaeff.Reader.Make(struct type t = env end) 7 | let get_version () = (Eff.read ()).version 8 | let get_starting_dir () = (Eff.read ()).starting_dir 9 | let run ~version ?starting_dir = Eff.run ~env:{version; starting_dir} 10 | 11 | let dispatch lookup param = 12 | let name, param = Marshal.destruct Json_encoding.(tup2 string any_ezjson_value) param in 13 | match lookup name with 14 | | Some route -> route param 15 | | None -> Reporter.fatalf LibraryNotFound "no@ router@ is@ called@ `%s'" name 16 | 17 | let fix ?(hop_limit=255) (f : t -> t) route = 18 | let rec go i route = 19 | if i <= 0 then 20 | Reporter.fatalf LibraryNotFound "exceeded@ hop@ limit@ (%d)" hop_limit 21 | else 22 | f (go (i-1)) route 23 | in 24 | f (go hop_limit) route 25 | 26 | let git = Git.route 27 | 28 | let file ?relative_to ~expanding_tilde param = 29 | let path = Marshal.destruct Json_encoding.string param in 30 | let expanding_tilde = if expanding_tilde then Some (File.get_home ()) else None in 31 | FilePath.of_string ?relative_to ?expanding_tilde path 32 | 33 | let rewrite_try_once lookup param = 34 | let param = Marshal.normalize param in 35 | Option.value ~default:param (lookup param) 36 | 37 | let rewrite_err_on_missing lookup param = 38 | let param = Marshal.normalize param in 39 | match lookup param with 40 | | None -> Reporter.fatalf LibraryNotFound "entry@ `%s'@ does@ not@ exist" (Marshal.to_string param) 41 | | Some param -> param 42 | 43 | let rewrite_recursively max_tries lookup param = 44 | let rec go i = 45 | if i = max_tries then 46 | Reporter.fatalf LibraryNotFound "could@ not@ resolve@ %s@ within@ %i@ rewrites" (Marshal.to_string param) max_tries 47 | else 48 | let param = Marshal.normalize param in 49 | match lookup param with 50 | | None -> go (i+1) 51 | | Some param -> param 52 | in go 0 53 | 54 | let rewrite ?(mode=`TryOnce) lookup param = 55 | match mode with 56 | | `TryOnce -> rewrite_try_once lookup param 57 | | `ErrOnMissing -> rewrite_err_on_missing lookup param 58 | | `Recursively i -> rewrite_recursively i lookup param 59 | 60 | (** Configuration files *) 61 | 62 | type table = Table.t 63 | let lookup_table = Table.lookup 64 | let parse_table s = Table.parse ~version:(get_version ()) s 65 | let read_table p = Table.read ~version:(get_version ()) p 66 | let get_web_table u = Table.get_web ~version:(get_version ()) u 67 | let write_table p tbl = Table.write ~version:(get_version ()) p tbl 68 | -------------------------------------------------------------------------------- /src/internal/Library.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { root : FilePath.t 3 | ; anchor : string 4 | ; loaded_anchor : Anchor.t 5 | } 6 | 7 | let (/) = FilePath.add_unit_seg 8 | 9 | let load_from_root ~version ~premount ~find_cache ~anchor root = 10 | Reporter.tracef "when@ loading@ library@ at@ `%a'" 11 | (FilePath.pp ~relative_to:(File.get_cwd ())) root @@ fun () -> 12 | let root = FilePath.to_dir_path root in 13 | match find_cache root with 14 | | Some lib -> lib 15 | | None -> 16 | let loaded_anchor = Anchor.read ~version ~premount (root/anchor) in 17 | {root; anchor; loaded_anchor} 18 | 19 | let load_from_dir ~version ~premount ~find_cache ~anchor dir = 20 | Reporter.tracef "when@ loading@ library@ from@ the@ directory@ `%a'" 21 | (FilePath.pp ~relative_to:(File.get_cwd ())) dir @@ fun () -> 22 | let dir = FilePath.to_dir_path dir in 23 | match File.locate_anchor ~anchor dir with 24 | | root, prefix -> 25 | let lib = load_from_root ~version ~premount ~find_cache ~anchor root in 26 | if Anchor.path_is_local lib.loaded_anchor prefix 27 | then lib, Some prefix 28 | else lib, None 29 | 30 | let load_from_unit ~version ~premount ~find_cache ~anchor filepath ~suffix = 31 | Reporter.tracef "when@ loading@ library@ of@ the@ unit@ at@ `%a'" 32 | (FilePath.pp ~relative_to:(File.get_cwd ())) filepath @@ fun () -> 33 | if not @@ File.file_exists filepath then 34 | Reporter.fatalf UnitNotFound "the@ unit@ `%a'@ does@ not@ exist" (FilePath.pp ~relative_to:(File.get_cwd ())) filepath 35 | else 36 | if FilePath.has_ext suffix filepath then 37 | Reporter.fatalf IllFormedFilePath "the@ file@ path@ `%a'@ does@ not@ have@ the@ suffix@ `%s'" (FilePath.pp ~relative_to:(File.get_cwd ())) filepath suffix; 38 | let filepath = FilePath.rem_ext filepath in 39 | let root, path_opt = 40 | load_from_dir ~version ~premount ~find_cache ~anchor (FilePath.parent filepath) 41 | in 42 | root, Option.map (fun path -> UnitPath.add_seg path (FilePath.basename filepath)) path_opt 43 | 44 | let root lib = lib.root 45 | 46 | let dispatch_path ~depth local ~global (lib : t) (path : UnitPath.t) = 47 | Reporter.tracef "when@ dispatching@ the@ path@ `%a'" UnitPath.pp path @@ fun () -> 48 | match Anchor.dispatch_path lib.loaded_anchor path with 49 | | None -> local lib path 50 | | Some (route, path) -> 51 | global ~depth:(depth+1) ?starting_dir:(Some lib.root) route path 52 | 53 | let resolve_local lib path ~suffix = 54 | Reporter.tracef "when@ resolving@ local@ unit@ path@ `%a'" UnitPath.pp path @@ fun () -> 55 | if UnitPath.is_root path then Reporter.fatalf UnitNotFound "the unit path is empty"; 56 | match File.locate_hijacking_anchor ~anchor:lib.anchor ~root:lib.root path with 57 | | Some anchor -> 58 | Reporter.fatalf HijackingAnchor 59 | "there@ is@ an@ anchor@ at@ `%a'@ hijacking@ the@ unit@ `%a'@ of@ the@ library@ at@ `%a'" 60 | (FilePath.pp ~relative_to:(File.get_cwd ())) anchor 61 | UnitPath.pp path 62 | (FilePath.pp ~relative_to:(File.get_cwd ())) lib.root 63 | | None -> 64 | lib, path, FilePath.add_ext suffix (FilePath.append_unit lib.root path) 65 | 66 | (** @param suffix The suffix should include the dot. *) 67 | let resolve ~depth = dispatch_path ~depth resolve_local 68 | -------------------------------------------------------------------------------- /test/Example.ml: -------------------------------------------------------------------------------- 1 | (** Set up the effect handler of error messages. See the documentation of Asai. *) 2 | module Terminal = Asai.Tty.Make(Bantorra.Reporter.Message) 3 | let run_bantorra f = Bantorra.Reporter.run f 4 | ~emit:Terminal.display ~fatal:(fun d -> Terminal.display d; failwith "error") 5 | 6 | open Bantorra 7 | 8 | (** Get the current working directory. *) 9 | let cwd = run_bantorra File.get_cwd 10 | 11 | (** Create the router. 12 | 13 | This router will route [["file", path]] to file [path] and 14 | [["git", git_params]] to the git repo specified by [git_params], 15 | placing cloned git repositories under the directory [_build/git]. 16 | *) 17 | let router = run_bantorra @@ fun () -> 18 | (* This is for calculating the absolute path to [_build/git]. *) 19 | let current_lib_root, _ = File.locate_anchor ~anchor:"anchor.json" cwd in 20 | Router.dispatch @@ 21 | function 22 | | "file" -> Option.some @@ 23 | Router.file ?relative_to:(Router.get_starting_dir ()) ~expanding_tilde:true 24 | | "git" -> Option.some @@ 25 | Router.git (FilePath.of_string ~relative_to:current_lib_root "./_build/git") 26 | | _ -> None 27 | 28 | (** Get a library manager. *) 29 | let manager = run_bantorra @@ fun () -> Manager.init ~version:"1.0.0" ~anchor:"anchor.json" router 30 | 31 | (** Load the library where the current directory belongs. *) 32 | let lib_cwd, _ = run_bantorra @@ fun () -> Manager.load_library_from_cwd manager 33 | 34 | (** Load a library using the router. *) 35 | let lib_number = 36 | run_bantorra @@ fun () -> 37 | Manager.load_library_from_route manager 38 | (* The argument sent to the router, as a JSON value. *) 39 | (`A [`String "file"; `String "./lib/number"]) 40 | (* Use the current directory as the starting directory (or the relative paths will fail). *) 41 | ~starting_dir:cwd 42 | 43 | (** Directly load the library from its root without using any routing. 44 | (The manager will return the same library as [lib_number].) *) 45 | let lib_number2 = 46 | run_bantorra @@ fun () -> 47 | Manager.load_library_from_root manager @@ 48 | FilePath.of_string ~relative_to:cwd "./lib/number/" 49 | 50 | (** Directly load a remote git repository. *) 51 | let lib_bantorra = 52 | run_bantorra @@ fun () -> 53 | Manager.load_library_from_route manager @@ 54 | `A [`String "git"; `O ["url", `String "https://github.com/RedPRL/bantorra"; "path", `String "test/lib/number/"]] 55 | 56 | (** Show where the cloned git repository is. *) 57 | let () = 58 | run_bantorra @@ fun () -> 59 | Format.printf "Git repo downloaded at %a@." (FilePath.pp ~relative_to:cwd) (Manager.library_root lib_bantorra) 60 | 61 | (** Resolve a unit path and get its location in the file system. *) 62 | let _local_lib, _local_path, filepath1 = 63 | run_bantorra @@ fun () -> 64 | Manager.resolve manager lib_number (UnitPath.of_string "types") ~suffix:".data" 65 | 66 | (** Resolve the same unit path but with a different suffix. *) 67 | let _local_lib, _local_path, filepath2 = 68 | run_bantorra @@ fun () -> 69 | Manager.resolve manager lib_number (UnitPath.of_string "types") ~suffix:".compiled" 70 | 71 | (** Resolve another unit path and get its location in the file system. 72 | The result is the same as above, assuming that the library [lib_number] 73 | is mounted at [std/num], for example using the following anchor file: 74 | 75 | {v 76 | { 77 | "format": "1.0.0", 78 | "mounts": { "std/num": ["file", "./lib/number"] } 79 | } 80 | v} 81 | *) 82 | let _local_lib, _local_path, filepath3 = 83 | run_bantorra @@ fun () -> 84 | Manager.resolve manager lib_cwd (UnitPath.of_string "std/num/types") ~suffix:".compiled" 85 | 86 | let () = 87 | run_bantorra @@ fun () -> 88 | assert (FilePath.equal filepath1 (FilePath.of_string ~relative_to:cwd "./lib/number/types.data")) 89 | 90 | let () = 91 | run_bantorra @@ fun () -> 92 | assert (FilePath.equal filepath2 (FilePath.of_string ~relative_to:cwd "./lib/number/types.compiled")) 93 | 94 | let () = 95 | run_bantorra @@ fun () -> 96 | assert (FilePath.equal filepath3 (FilePath.of_string ~relative_to:cwd "./lib/number/types.compiled")) 97 | -------------------------------------------------------------------------------- /src/Manager.mli: -------------------------------------------------------------------------------- 1 | (** Library managers. *) 2 | 3 | (** {1 Types} *) 4 | 5 | type t 6 | (** The type of library managers. *) 7 | 8 | type library 9 | (** The abstract type of libraries. *) 10 | 11 | type path = UnitPath.t 12 | (** The type of unit paths. *) 13 | 14 | (** {1 Initialization} *) 15 | 16 | val init : version:string -> anchor:string -> ?premount:Router.param Trie.t -> Router.t -> t 17 | (** [init ~anchor router] initiates a library manager for loading libraries. 18 | 19 | @param version Format version of anchors and routing-related files. 20 | @param anchor The file name of the anchors. 21 | @param premount The pre-mounted routes. 22 | @param router The router. See {!module:Router}. 23 | *) 24 | 25 | (** {1 Library Loading} *) 26 | 27 | (** A library is identified by a JSON file in its root directory, which is called an {e anchor}. *) 28 | 29 | val load_library_from_root : t -> FilePath.t -> library 30 | (** [load_library_from_root manager lib_root] loads the library at the directory [lib_root] 31 | from the file system. It is assumed that there is an anchor file is right at [lib_root]. 32 | 33 | @param manager The library manager. 34 | @param lib_root The root of the library, which should be a directory. 35 | @return The loaded library. 36 | *) 37 | 38 | val load_library_from_route : t -> ?starting_dir:FilePath.t -> Router.param -> library 39 | (** [load_library_from_root manager param] loads the library by following the [param]. 40 | 41 | @param manager The library manager. 42 | @param starting_dir The starting directory. 43 | @param param The route specification, as a JSON value. 44 | @return The loaded library. 45 | *) 46 | 47 | val load_library_from_route_with_cwd : t -> Router.param -> library 48 | (** [load_library_from_root manager param] is 49 | {!val:load_library_from_route}[ manager ~relative_to:cwd param] 50 | where [cwd] is the current working directory. 51 | *) 52 | 53 | val load_library_from_dir : t -> FilePath.t -> library * path option 54 | (** [load_library_from_dir manager dir] assumes the directory [dir] resides in some library 55 | and will try to find the root of the library by locating the anchor file. 56 | It then loads the library marked by the anchor. 57 | 58 | @param manager The library manager. 59 | @param dir A directory that is assumed to be inside some library. 60 | @return The loaded library and the unit path 61 | *) 62 | 63 | val load_library_from_cwd : t -> library * path option 64 | (** [load_library_from_cwd manager] is {!val:load_library_from_dir}[ manager dir] 65 | with [dir] being the current working director. 66 | *) 67 | 68 | val load_library_from_unit : t -> FilePath.t -> suffix:string -> library * path option 69 | (** [locate_anchor_from_unit filepath ~suffix] assumes [filepath] ends with [suffix] 70 | and the file at [filepath] resides in some library. It will try to find the root of the library 71 | and load the library. 72 | 73 | @param manager The library manager. 74 | @param filepath The corresponding file path. 75 | @param suffix The suffix of the unit on the file system. Note that the dot is included in the suffix---the suffix of [file.ml] is [.ml], not [ml]. 76 | @return The loaded library and the unit path in the library. The unit path is [None] if the file is actually inaccessible, probably due to another mounted library shadowing the unit. 77 | *) 78 | 79 | val library_root : library -> FilePath.t 80 | (** Get the root directory of a library. *) 81 | 82 | (** {1 Composite Resolver} 83 | 84 | These functions will automatically load the dependencies. 85 | *) 86 | 87 | val resolve : 88 | t -> ?max_depth:int -> library -> path -> suffix:string -> library * path * FilePath.t 89 | (** [resolve manager lib path ~suffix] resolves [path] in the library in the library [lib] and returns a triple [(lib, upath, fpath)] where [lib] is the {e eventual} library where the unit belongs, [upath] is the unit path in the eventual library [lib], and [fpath] is the corresponding file path with the specified suffix. 90 | 91 | @param manager The library manager. 92 | @param max_depth Maximum depth for resolving recursive library mounting. The default value is [255]. 93 | @param lib The library. 94 | @param path The unit path to be resolved. 95 | @param suffix The suffix shared by all the units in the file system. 96 | *) 97 | -------------------------------------------------------------------------------- /docs/index.mld: -------------------------------------------------------------------------------- 1 | {0 bantorra: Library Management} 2 | 3 | {1 Introduction} 4 | 5 | A {e library} in the bantorra framework is a tree of units that can be accessed via unit paths from the root. A unit path is a list of strings, such as [lib/num/types]. The purpose of the bantorra framework is to provide a flexible mechanism to map each unit path to some underlying file path. For example, the unit path [lib/num/types] might be mapped to the file path [/usr/lib/cool/number/types.data], and the resolution process takes in both what is set up by the application and what is provided by its users. 6 | 7 | In the simplest case, there is a one-to-one correspondence between units and files under a directory: the unit path [a/b/c] corresponds to the file [a/b/c.data] where [.data] is the extension specified by the application. The root directory is marked by a special file called {e anchor}, which is a file with a fixed name again specified by the application. For example, the existence of a [dune] file means there is an OCaml library in the eyes of the [dune] building tool. An anchor in the bantorra framework marks the root of a library. If the anchor file name is [anchor.json], the file at [/usr/lib/cool/number/anchor.json] indicates that there is a library containing files under [/usr/lib/cool/number]. 8 | 9 | It is common for units within a library to access units in another library. To do so, an anchor file may {e mount} another library in the tree, in a way similar to how partitions are mounted in POSIX-compliant systems. Here is a sample anchor file: 10 | {v 11 | { 12 | "format": "1.0.0", 13 | "mounts": { 14 | "lib/num": ["local", "/usr/lib/cool/number"] 15 | } 16 | } 17 | v} 18 | 19 | The above anchor file presumably mounts the library [number] at [lib/num]. With this, the unit path [lib/num/types] will be routed to the unit [types] within the library [number]. The resolution is recursive because the mounted library may mount yet another library. The JSON array [["local", "/usr/lib/cool/number"]] specifies where the location of the library, and the application has full control of how to interpret the location specification [["local", "/usr/lib/cool/number"]]. The example assumes that [["local", path]] refers to [path] in a local file system, but the application can choose to use any OCaml function from JSON data to directory paths. A few basic routing functions are provided in {!module:Bantorra.Router}. 20 | 21 | {1 Anchors} 22 | 23 | As mentioned earlier, an anchor file looks like this: 24 | 25 | {v 26 | { 27 | "format": ...version of the anchor format..., 28 | "mounts": { 29 | "path/to/lib1": ...(spec of lib1)... 30 | "path/to/lib2": ...(spec of lib2)... 31 | ... 32 | "path/to/libn": ...(spec of libn)... 33 | } 34 | } 35 | v} 36 | 37 | The [format] version string is decided by the application; it can help detect outdated anchor files. As for the [mounts] property, if it is missing, then the library has no dependencies. Each dependency is specified by a key/value pair, where the key is the mount point and value is the parameter for locating the library. During the resolution, the entire parameter is passed to the router. See {!type:Bantorra.Router.t} and {!type:Bantorra.Router.param}. The order of entries in [mounts] does not matter because the dispatching is based on longest prefix match. If no match can be found, then it means the unit path refers to a local unit. The same library can be mounted at multiple points. However, to keep the resolution unambiguous, there cannot be two libraries mounted at the same point. Here is an example demonstrating the longest prefix match: 38 | 39 | {v 40 | { 41 | "format": "1.0.0", 42 | "mounts": { 43 | "lib": "stdlib", 44 | "lib/bantorra": ["git", {url: "https://github.com/RedPRL/bantorra"}] 45 | } 46 | } 47 | v} 48 | 49 | The unit path [lib/orntorra] will be routed to the unit [orntorra] within the [stdlib] library, pending further resolution (as the [stdlib] library might further mount other libraries), while the unit path [lib/bantorra/shisho] will be routed to the git repo [https://github.com/RedPRL/bantorra], not the unit [bantorra/shisho] in the [stdlib] library, because [lib/bantorra] matches [lib/bantorra/shisho] better than [lib] does. 50 | 51 | Note that, if some library is mounted at [world/towitorra], then the original local unit with the unit path [world/towitorra] will no longer be accessible. As an analogy using the POSIX-compliant [mount], the original files within [/mnt] will not be accessible after mounting a file system at [/mnt]. 52 | 53 | {1 Links} 54 | 55 | - {{:https://github.com/RedPRL/bantorra/blob/main/test/Example.ml}An example} (available locally as [test/Example.ml]). 56 | - {{!module:Bantorra}The API documentation.} 57 | -------------------------------------------------------------------------------- /src/internal/Git.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { root : FilePath.t 3 | ; lock : Mutex.t 4 | ; hash_in_use : (string, string) Hashtbl.t 5 | ; url_in_use : (string, string) Hashtbl.t 6 | } 7 | 8 | let loaded_crates : (FilePath.t, t) Hashtbl.t = Hashtbl.create 5 9 | 10 | type param = 11 | { url : string 12 | ; ref : string 13 | ; path : UnitPath.t 14 | } 15 | 16 | module Json = 17 | struct 18 | module J = Json_encoding 19 | 20 | let url = J.req ~title:"URL" ~description:"Git repository URL to check out" "url" J.string 21 | let ref = J.dft ~title:"Git ref" ~description:"Git ref or object name (hash) to check out" "ref" J.string "HEAD" 22 | let path = J.dft ~title:"path" ~description:"path within a Git repository" "path" J.string "./" 23 | let param = J.obj3 url ref path 24 | end 25 | 26 | let parse_param json : param = 27 | let url, ref, path = Marshal.destruct Json.param json in 28 | let path = UnitPath.of_string ~allow_ending_slash:true ~allow_extra_dots:true path in 29 | {url; ref; path} 30 | 31 | module G = 32 | struct 33 | open Bos 34 | 35 | let wrap_bos = 36 | function 37 | | Ok r -> r 38 | | Error (`Msg m) -> Reporter.fatalf LibraryNotFound "@[<2>@[routing@ failed:@]@ %s@]" m 39 | 40 | let git ~root = Cmd.(v "git" % "-C" % FilePath.to_string root) 41 | 42 | let run_null ?err cmd = wrap_bos @@ Bos.OS.Cmd.(in_null |> run_io ?err cmd |> to_null) 43 | 44 | let git_check_ref_format ~root ~ref = 45 | run_null Cmd.(git ~root % "check-ref-format" % "--allow-onelevel" % ref) 46 | 47 | let git_init ~root = 48 | run_null Cmd.(git ~root % "init" % "--quiet") 49 | 50 | let git_remote_reset_origin ~root ~url = 51 | begin 52 | Reporter.try_with ~fatal:(fun _ -> ()) ~emit:(fun _ -> ()) @@ fun () -> 53 | run_null ~err:Bos.OS.Cmd.err_null Cmd.(git ~root % "remote" % "remove" % "origin") 54 | end; 55 | run_null Cmd.(git ~root % "remote" % "add" % "origin" % url) 56 | 57 | let git_fetch_origin ~err_on_failed_fetch ~root ~ref = 58 | let strict () = 59 | run_null Cmd.(git ~root % "fetch" % "--quiet" % "--no-tags" % "--recurse-submodules=on-demand" % "--depth=1" % "origin" % ref); 60 | run_null Cmd.(git ~root % "reset" % "--quiet" % "--hard" % "--recurse-submodules" % "FETCH_HEAD" % "--") 61 | in 62 | let relaxed () = 63 | Reporter.try_with strict ~fatal:Reporter.emit_diagnostic 64 | in 65 | if err_on_failed_fetch then strict () else relaxed () 66 | 67 | let git_rev_parse ~root ~ref = 68 | wrap_bos @@ Bos.OS.Cmd.(in_null |> run_io Cmd.(git ~root % "rev-parse" % "--verify" % "--end-of-options" % ref) |> to_string) 69 | 70 | let reset_repo ~err_on_failed_fetch ~url ~ref ~root ~hash_in_use = 71 | File.ensure_dir root; 72 | git_init ~root; 73 | git_check_ref_format ~root ~ref; 74 | git_remote_reset_origin ~root ~url; 75 | git_fetch_origin ~err_on_failed_fetch ~root ~ref; 76 | match hash_in_use with 77 | | None -> 78 | git_rev_parse ~root ~ref:"HEAD" 79 | | Some hash_in_use -> 80 | let hash = git_rev_parse ~root ~ref:"HEAD" in 81 | if hash_in_use <> hash then 82 | Reporter.fatalf LibraryConflict "inconsistent@ Git@ commits@ %s@ and@ %s@ are@ used@ for@ `%s'" hash hash_in_use (String.escaped url) 83 | else 84 | hash 85 | end 86 | 87 | (* more checking about [ref] *) 88 | let load_git_repo ~err_on_failed_fetch {root; lock; hash_in_use; url_in_use} {url; ref; path} = 89 | Reporter.tracef "when@ loading@ the@ git@ repository@ at@ `%s'" url @@ fun () -> 90 | Mutex.protect lock @@ fun () -> 91 | let url_digest = Digest.to_hex @@ Digest.string url in 92 | let git_root = FilePath.append_unit root (UnitPath.of_list ["repos"; url_digest]) in 93 | begin 94 | match Hashtbl.find_opt url_in_use url_digest with 95 | | Some url_in_use when url_in_use <> url -> 96 | Reporter.fatalf InvalidRouter "unexpected@ hash@ collision@ of@ URLs@ `%s'@ and@ `%s'" url url_in_use 97 | | _ -> () 98 | end; 99 | let hash = 100 | G.reset_repo ~err_on_failed_fetch ~root:git_root ~url ~ref 101 | ~hash_in_use:(Hashtbl.find_opt hash_in_use url_digest) 102 | in 103 | Hashtbl.replace hash_in_use url_digest hash; 104 | Hashtbl.replace url_in_use url_digest url; 105 | FilePath.append_unit git_root path 106 | 107 | let global_lock = Mutex.create () 108 | 109 | let load_crate crate_root = 110 | Mutex.protect global_lock @@ fun () -> 111 | match Hashtbl.find_opt loaded_crates crate_root with 112 | | Some crate -> crate 113 | | None -> File.ensure_dir crate_root; 114 | let crate = {root = crate_root; lock = Mutex.create (); hash_in_use = Hashtbl.create 5; url_in_use = Hashtbl.create 5} in 115 | Hashtbl.replace loaded_crates crate_root crate; 116 | crate 117 | 118 | let route ?(err_on_failed_fetch=true) crate = 119 | let crate = load_crate crate in 120 | fun param -> load_git_repo ~err_on_failed_fetch crate @@ parse_param param 121 | -------------------------------------------------------------------------------- /src/Router.mli: -------------------------------------------------------------------------------- 1 | (** Routers. *) 2 | 3 | (** {1 Types} *) 4 | 5 | type param = Marshal.value 6 | (** The type of parameters to routers. *) 7 | 8 | type t = param -> FilePath.t 9 | (** The type of library routers. A router is a function from JSON parameters to file paths. *) 10 | 11 | type pipe = param -> param 12 | (** The type of parameter transformers. *) 13 | 14 | type table = (Marshal.value, Marshal.value) Hashtbl.t 15 | (** The type of parameter rewrite tables. The invariant is that the keys should be {{!val:Marshal.normalize}normalized}. *) 16 | 17 | (** {1 Algebraic Effects} *) 18 | 19 | val get_version : unit -> string 20 | (** Get the format version string used by the library manager. *) 21 | 22 | val get_starting_dir : unit -> FilePath.t option 23 | (** Get the starting directory of the resolution, usually the root of the library mounting the current route. That is, if a library X is mounting library Y, the starting directory is usually the root of X when locating the library Y. That said, an application can explicitly specify the starting directory when locating a library. *) 24 | 25 | val run : version:string -> ?starting_dir:FilePath.t -> (unit -> 'a) -> 'a 26 | (** Handle the algebraic effects generated by {!val:get_starting_dir}. *) 27 | 28 | (** {1 Built-in Routers and Utility Functions} *) 29 | 30 | (** {2 Router Combinators} *) 31 | 32 | val dispatch : (string -> t option) -> t 33 | (** [dispatch lookup] accepts JSON arrays of the form [[name, arg]] and runs the router [lookup name] with the JSON parameter [arg] *) 34 | 35 | val rewrite : ?mode:[ `TryOnce | `ErrOnMissing | `Recursively of int ] -> (param -> param option) -> pipe 36 | (** [rewrite lookup] rewrites the JSON parameter [param] to [param'] if [lookup param] is [Some param']. 37 | Otherwise, if [lookup param] is [None], the [param] is returned unchanged. 38 | 39 | @param mode [`Recursively t] means applying [lookup] until it returns [None], and then the parameter before reaching [None] is returned. [`ErrOnMissing] means erring when [lookup param] is [None] (instead of returning the original parameter) when [lookup param] is [None]. 40 | *) 41 | 42 | val fix : ?hop_limit:int -> (t -> t) -> t 43 | (** [fix f] gives the fixed point of [f]. 44 | 45 | @param hop_limit The maximum depth of recursive routing. [0] means no recursive calls and [1] means recursion at most once. The default value is [255]. 46 | *) 47 | 48 | (** {2 Base Routers} *) 49 | 50 | val file : ?relative_to:FilePath.t -> expanding_tilde:bool -> t 51 | (** [file] accepts a JSON string [path] and return the [path] as a file path. 52 | 53 | @param relative_to The base directory to turn relative paths to absolute paths. Without setting this argument, relative paths will be rejected. 54 | @param expanding_tilde Whether to expand the tilde prefix in a path. (Recommended in most cases.) 55 | *) 56 | 57 | val git : ?err_on_failed_fetch:bool -> FilePath.t -> t 58 | (** [git ~crate] accepts JSON parameters in one of the following formats: 59 | 60 | {v 61 | { "url": "git@github.com:RedPRL/bantorra.git" } 62 | v} 63 | {v 64 | { 65 | "url": "git@github.com:RedPRL/bantorra.git", 66 | "ref": "main" 67 | } 68 | v} 69 | {v 70 | { 71 | "url": "git@github.com:RedPRL/bantorra.git", 72 | "path": "src/library/" 73 | } 74 | v} 75 | {v 76 | { 77 | "url": "git@github.com:RedPRL/bantorra.git", 78 | "ref": "main", 79 | "path": "src/library/" 80 | } 81 | v} 82 | The [ref] field can be a commit hash (object name), a branch name, a tag name, or essentially anything accepted by [git fetch]. (The older [git] before year 2015 would not accept commit IDs, but please upgrade it already.) The [path] field is the relative path pointing to the root of the library. If the [path] field is missing, then the tool assumes the library is at the root of the repository. If the [ref] field is missing, then ["HEAD"] is used, which points to the tip of the default branch in the remote repository. 83 | 84 | Different URLs pointing to the "same" git repository are treated as different repositories. Therefore, [git@github.com:RedPRL/bantorra.git] and [https://github.com/RedPRL/bantorra.git] are treated as two distinct git repositories. For the same repository, the commits in use must be identical during the program execution; one can use different branch names or tag names, but they must point to the same commit. The resolution would fail if there is an attempt to use different commits of the same repository. 85 | *) 86 | 87 | (** {2 Configuration Files} *) 88 | 89 | (** 90 | Format of the configuration files: 91 | 92 | {v 93 | { 94 | "format": "1.0.0", 95 | "rewrite": [ ["stdlib", "~/coollib/stdlib"] ] 96 | } 97 | v} 98 | 99 | [rewrite] is an array of pairs of JSON values. If the property [rewrite] is missing, it is understood as the empty array. The array will be parsed as a {{!type:table}rewrite table}. The table is intended to be used with {!val:rewrite} as follows: 100 | {[ 101 | rewrite (lookup_table (read_table ~version:"1.0.0" "file")) 102 | ]} 103 | 104 | Note: the format version string of the configuration files should match that used by the library manager. 105 | *) 106 | 107 | val lookup_table : table -> param -> param option 108 | (** [lookup_table table param] looks up the (normalized) [param] in [table]. *) 109 | 110 | val parse_table : string -> table 111 | (** [parse_table str] parse [str] as a table. *) 112 | 113 | val read_table : FilePath.t -> table 114 | (** [read_table path] is [parse_table ~version (File.read path)]. *) 115 | 116 | val get_web_table : string -> table 117 | (** [get_web_table path] is [parse_table ~version (Web.get url)]. *) 118 | 119 | val write_table : FilePath.t -> table -> unit 120 | (** [write_table path table] writes table to the file at [path]. *) 121 | -------------------------------------------------------------------------------- /src/File.ml: -------------------------------------------------------------------------------- 1 | module U = Unix 2 | module F = FilePath 3 | 4 | (* invariant: absolute path *) 5 | type path = F.t 6 | 7 | let (/) = F.add_unit_seg 8 | 9 | let wrap_bos_error code = 10 | function 11 | | Ok r -> r 12 | | Error (`Msg msg) -> Reporter.fatal code msg 13 | 14 | let get_cwd () = F.of_fpath @@ wrap_bos_error SystemError @@ Bos.OS.Dir.current () 15 | 16 | (** Read the entire file as a string. *) 17 | let read p = 18 | Reporter.tracef "when@ reading@ the@ file@ `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> 19 | wrap_bos_error FileError @@ Bos.OS.File.read (F.to_fpath p) 20 | 21 | (** Write a string to a file. *) 22 | let write p s = 23 | Reporter.tracef "when@ writing@ the@ file@ `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> 24 | wrap_bos_error FileError @@ Bos.OS.File.write (F.to_fpath p) s 25 | 26 | let ensure_dir p = 27 | Reporter.tracef "when@ calling@ `ensure_dir'@ on@ `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> 28 | ignore @@ wrap_bos_error FileError @@ Bos.OS.Dir.create (F.to_fpath p) 29 | 30 | let file_exists p = 31 | wrap_bos_error FileError @@ Bos.OS.File.exists (F.to_fpath p) 32 | 33 | let locate_anchor ~anchor start_dir = 34 | Reporter.tracef "when@ locating@ the@ anchor@ `%s'@ from@ `%a'" 35 | anchor (F.pp ~relative_to:(get_cwd())) start_dir @@ fun () -> 36 | let rec go cwd path_acc = 37 | if file_exists (cwd/anchor) then 38 | cwd, UnitPath.of_list path_acc 39 | else 40 | if F.is_root cwd 41 | then Reporter.fatalf AnchorNotFound "no@ anchor@ found@ all@ the@ way@ up@ to@ the@ root" 42 | else go (F.parent cwd) @@ F.basename cwd :: path_acc 43 | in 44 | go (F.to_dir_path start_dir) [] 45 | 46 | let locate_hijacking_anchor ~anchor ~root path = 47 | Reporter.tracef "when@ checking@ whether@ there's@ any@ hijacking@ anchor@ `%s'@ between@ `%a' and@ `%a'" 48 | anchor (F.pp ~relative_to:(get_cwd())) root UnitPath.pp path @@ fun () -> 49 | match UnitPath.to_list path with 50 | | [] -> None 51 | | first_seg :: segs -> 52 | let rec loop cwd parts = 53 | if file_exists (cwd/anchor) then 54 | Some cwd 55 | else 56 | match parts with 57 | | [] -> None 58 | | seg :: segs -> 59 | loop (cwd/seg) segs 60 | in 61 | loop (root/first_seg) segs 62 | 63 | (** The scheme refers to how various directories should be determined. 64 | 65 | It does not correspond to the actual OS that is running. For example, the 66 | [Linux] scheme covers all BSD-like systems and Cygwin on Windows. *) 67 | type scheme = MacOS | Linux | Windows 68 | 69 | let uname_s = 70 | lazy begin 71 | Result.to_option @@ 72 | Bos.OS.Cmd.(in_null |> run_io Bos.Cmd.(v "uname" % "-s") |> to_string ~trim:true) 73 | end 74 | 75 | let guess_scheme = 76 | lazy begin 77 | match Sys.os_type with 78 | | "Unix" -> 79 | begin 80 | match Lazy.force uname_s with 81 | | Some "Darwin" -> MacOS 82 | | _ -> Linux 83 | end 84 | | "Cygwin" -> Linux 85 | | "Win32" -> Windows 86 | | _ -> Linux 87 | end 88 | 89 | let get_home () = 90 | F.of_fpath @@ wrap_bos_error MissingEnvironmentVariables @@ Bos.OS.Dir.user () 91 | 92 | let read_env_path var = 93 | Result.map (F.of_fpath ~relative_to:(get_cwd ())) @@ Bos.OS.Env.path var 94 | 95 | (* XXX I did not test the following code on different platforms. *) 96 | let get_xdg_config_home ~app_name = 97 | Reporter.tracef "when@ determining@ the@ value@ of@ XDG_CONFIG_HOME" @@ fun () -> 98 | match read_env_path "XDG_CONFIG_HOME" with 99 | | Ok dir -> dir/app_name 100 | | Error _ -> 101 | match Lazy.force guess_scheme with 102 | | Linux -> 103 | let home = 104 | Reporter.try_with get_home 105 | ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CONFIG_HOME@ and@ HOME@ are@ absent") 106 | in 107 | home/".config"/app_name 108 | | MacOS -> 109 | let home = 110 | Reporter.try_with get_home 111 | ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CONFIG_HOME@ and@ HOME@ are@ absent") 112 | in 113 | home/"Library"/"Application Support"/app_name 114 | | Windows -> 115 | begin 116 | match read_env_path "APPDATA" with 117 | | Ok app_data -> 118 | app_data/app_name/"config" 119 | | Error _ -> 120 | Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CONFIG_HOME@ and@ APPDATA@ are@ absent" 121 | end 122 | 123 | (* XXX I did not test the following code on different platforms. *) 124 | let get_xdg_cache_home ~app_name = 125 | Reporter.tracef "when calculating XDG_CACHE_HOME" @@ fun () -> 126 | match read_env_path "XDG_CACHE_HOME" with 127 | | Ok dir -> dir/app_name 128 | | Error _ -> 129 | match Lazy.force guess_scheme with 130 | | Linux -> 131 | let home = 132 | Reporter.try_with get_home 133 | ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CACHE_HOME@ and@ HOME@ are@ absent") 134 | in 135 | home/".cache"/app_name 136 | | MacOS -> 137 | let home = 138 | Reporter.try_with get_home 139 | ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CACHE_HOME@ and@ HOME@ are@ absent") 140 | in 141 | home/"Library"/"Caches"/app_name 142 | | Windows -> 143 | begin 144 | match read_env_path "LOCALAPPDATA" with 145 | | Error _ -> 146 | Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CACHE_HOME@ and@ LOCALAPPDATA@ are@ absent" 147 | | Ok local_app_data -> 148 | local_app_data/app_name/"cache" 149 | end 150 | 151 | (** OCaml findlib *) 152 | 153 | let findlib_init = lazy begin Findlib.init () end 154 | 155 | let get_package_dir pkg = 156 | Lazy.force findlib_init; 157 | try 158 | FilePath.of_string @@ Findlib.package_directory pkg 159 | with 160 | | Findlib.No_such_package (pkg, msg) -> 161 | Reporter.fatalf InvalidOCamlPackage "@[<2>@[no@ package@ named@ `%s':@]@ %s@]" pkg msg 162 | | Findlib.Package_loop pkg -> 163 | Reporter.fatalf InvalidOCamlPackage "package@ `%s'@ is@ requiring@ itself@ (circularity)" pkg 164 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | 203 | 204 | --- LLVM Exceptions to the Apache 2.0 License ---- 205 | 206 | As an exception, if, as a result of your compiling your source code, portions 207 | of this Software are embedded into an Object form of such source code, you 208 | may redistribute such embedded portions in such Object form without complying 209 | with the conditions of Sections 4(a), 4(b) and 4(d) of the License. 210 | 211 | In addition, if you combine or link compiled forms of this Software with 212 | software that is licensed under the GPLv2 ("Combined Software") and if a 213 | court of competent jurisdiction determines that the patent provision (Section 214 | 3), the indemnity provision (Section 9) or other Section of the License 215 | conflicts with the conditions of the GPLv2, you may retroactively and 216 | prospectively choose to deem waived or otherwise exclude such Section(s) of 217 | the License, but only in their entirety and only with respect to the Combined 218 | Software. 219 | --------------------------------------------------------------------------------