diff --git a/src/build_system.ml b/src/build_system.ml index 0594ecb9..f595b419 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -212,29 +212,47 @@ module File_spec = struct end module Alias0 = struct - type t = { dir : Path.t; name : string } + module T : sig + type t = private + { dir : Path.t + ; name : string + } + val make : string -> dir:Path.t -> t + val of_user_written_path : loc:Loc.t -> Path.t -> t + end = struct + type t = + { dir : Path.t + ; name : string + } + + let make name ~dir = + if not (Path.is_in_build_dir dir) || String.contains name '/' then + Exn.code_error "Alias0.make: Invalid alias" + [ "name", Sexp.To_sexp.string name + ; "dir", Path.sexp_of_t dir + ]; + { dir; name } + + let of_user_written_path ~loc path = + if not (Path.is_in_build_dir path) then + Loc.fail loc "Invalid alias!\n\ + Tried to reference path outside build dir: %S" + (Path.to_string_maybe_quoted path); + { dir = Path.parent path + ; name = Path.basename path + } + end + include T let pp fmt t = Path.pp fmt (Path.relative t.dir t.name) let suffix = "-" ^ String.make 32 '0' - let of_path path = - if not (Path.is_in_build_dir path) then - die "Invalid alias!\nTried to reference alias %S" - (Path.to_string_maybe_quoted path); - { dir = Path.parent path - ; name = Path.basename path - } - let name t = t.name let dir t = t.dir let fully_qualified_name t = Path.relative t.dir t.name - let make name ~dir = - assert (not (String.contains name '/')); - { dir; name } - let stamp_file t = Path.relative (Path.insert_after_build_dir_exn t.dir ".aliases") (t.name ^ suffix) diff --git a/src/build_system.mli b/src/build_system.mli index d55c6a8f..4abbcd2b 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -99,7 +99,7 @@ module Alias : sig val make : string -> dir:Path.t -> t - val of_path : Path.t -> t + val of_user_written_path : loc:Loc.t -> Path.t -> t (** The following always holds: diff --git a/src/super_context.ml b/src/super_context.ml index 3787dc3f..29e8aaeb 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -457,7 +457,9 @@ module Deps = struct open Dep_conf let make_alias t ~scope ~dir s = - Alias.of_path (Path.relative dir (expand_vars t ~scope ~dir s)) + let loc = String_with_vars.loc s in + Alias.of_user_written_path ~loc + (Path.relative ~error_loc:loc dir (expand_vars t ~scope ~dir s)) let dep t ~scope ~dir = function | File s -> diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index f8dbff41..052e0b58 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -6,6 +6,14 @@ test-cases/aliases (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) +(alias + ((name bad-alias-error) + (deps ((package dune) (files_recursively_in test-cases/bad-alias-error))) + (action + (chdir + test-cases/bad-alias-error + (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) + (alias ((name byte-code-only) (deps ((package dune) (files_recursively_in test-cases/byte-code-only))) @@ -446,6 +454,7 @@ ((name runtest) (deps ((alias aliases) + (alias bad-alias-error) (alias byte-code-only) (alias c-stubs) (alias configurator) @@ -499,6 +508,7 @@ ((name runtest-no-deps) (deps ((alias aliases) + (alias bad-alias-error) (alias byte-code-only) (alias c-stubs) (alias configurator) diff --git a/test/blackbox-tests/test-cases/bad-alias-error/absolute-path/jbuild b/test/blackbox-tests/test-cases/bad-alias-error/absolute-path/jbuild new file mode 100644 index 00000000..789e60e0 --- /dev/null +++ b/test/blackbox-tests/test-cases/bad-alias-error/absolute-path/jbuild @@ -0,0 +1,3 @@ +(alias + ((name runtest) + (deps ((alias /foo/bar))))) diff --git a/test/blackbox-tests/test-cases/bad-alias-error/outside-workspace/jbuild b/test/blackbox-tests/test-cases/bad-alias-error/outside-workspace/jbuild new file mode 100644 index 00000000..d5050b8d --- /dev/null +++ b/test/blackbox-tests/test-cases/bad-alias-error/outside-workspace/jbuild @@ -0,0 +1,4 @@ + +(alias + ((name runtest) + (deps ((alias ${ROOT}/../../../foobar))))) diff --git a/test/blackbox-tests/test-cases/bad-alias-error/run.t b/test/blackbox-tests/test-cases/bad-alias-error/run.t new file mode 100644 index 00000000..67f63b48 --- /dev/null +++ b/test/blackbox-tests/test-cases/bad-alias-error/run.t @@ -0,0 +1,7 @@ + $ dune runtest --root absolute-path 2>&1 | grep -v Entering + File "jbuild", line 3, characters 16-24: + Error: Invalid alias! + Tried to reference path outside build dir: "/foo/bar" + $ dune runtest --root outside-workspace 2>&1 | grep -v Entering + File "jbuild", line 4, characters 16-39: + Error: path outside the workspace: ./../../../foobar from _build/default