From ee548a65b8857c8b8f8629c76e21c851c8e490c0 Mon Sep 17 00:00:00 2001 From: Etienne Millon Date: Thu, 3 Aug 2023 11:03:48 +0200 Subject: [PATCH] feature: check package names are valid opam names This adds a `Package_name.Strict` variant that uses opam conventions. The corresponding parser is used if lang dune >= 3.11. Signed-off-by: Etienne Millon --- CHANGES.md | 3 + src/dune_lang/package_name.ml | 53 ++- src/dune_lang/package_name.mli | 12 + src/dune_rules/dune_project.ml | 335 +++++++++--------- src/dune_rules/package.ml | 97 ++--- .../test-cases/package-name-strict.t | 55 +++ 6 files changed, 338 insertions(+), 217 deletions(-) create mode 100644 test/blackbox-tests/test-cases/package-name-strict.t diff --git a/CHANGES.md b/CHANGES.md index 93555786c663..9e068f8390a0 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -3,6 +3,9 @@ Unreleased - No longer emit linkopts(javascript) in META files (#8168, @hhugo) +- Ensure that package names in `dune-project` are valid opam package + names. (#...., @emillon) + 3.10.0 (2023-07-31) ------------------- diff --git a/src/dune_lang/package_name.ml b/src/dune_lang/package_name.ml index 6d7f0ed95898..349294a120ca 100644 --- a/src/dune_lang/package_name.ml +++ b/src/dune_lang/package_name.ml @@ -15,8 +15,55 @@ include ( let hint_valid = None - let of_string_opt s = - (* DUNE3 verify no dots or spaces *) - if s = "" then None else Some s + let of_string_opt s = if s = "" then None else Some s end) : Dune_util.Stringlike with type t := t) + +module Strict = struct + include Dune_util.Stringlike.Make (struct + type t = string + + let module_ = "Package.Name.Strict" + + let description = "package name" + + let to_string s = s + + let description_of_valid_string = + Some + (Pp.textf + "Package names start with a letter and can contain letters, \ + numbers, '-', '_' and '+'") + + let is_valid_char ~at_start = function + | 'a' .. 'z' | 'A' .. 'Z' -> true + | '0' .. '9' | '-' | '_' | '+' -> not at_start + | _ -> false + + let of_string_opt s = + let open Option.O in + let* empty = + String.fold_left s ~init:(Some true) ~f:(fun state c -> + let* at_start = state in + if is_valid_char ~at_start c then Some false else None) + in + Option.some_if (not empty) s + + let make_valid s = + let b = Buffer.create 0 in + let emit c = Buffer.add_char b c in + let (_ : bool) = + String.fold_left s ~init:true ~f:(fun at_start c -> + if is_valid_char ~at_start c then emit c + else if not at_start then emit '_'; + false) + in + match Buffer.contents b with + | "" -> "a" + | s -> s + + let hint_valid = Some make_valid + end) + + let to_package_name s = s +end diff --git a/src/dune_lang/package_name.mli b/src/dune_lang/package_name.mli index 5debe1c8730d..80e16f1858b7 100644 --- a/src/dune_lang/package_name.mli +++ b/src/dune_lang/package_name.mli @@ -14,3 +14,15 @@ include Comparable_intf.S with type key := t include Dune_sexp.Conv.S with type t := t include Stringlike with type t := t + +module Strict : sig + (** A variant that enforces opam package name constraints: + [[a-zA-Z][a-zA-Z0-9_+-]*] *) + + include Stringlike + + type package_name + + val to_package_name : t -> package_name +end +with type package_name := t diff --git a/src/dune_rules/dune_project.ml b/src/dune_rules/dune_project.ml index 09ef252f80cb..348b22ecbd7a 100644 --- a/src/dune_rules/dune_project.ml +++ b/src/dune_rules/dune_project.ml @@ -841,175 +841,172 @@ let parse_packages (name : Name.t option) ~info ~dir ~version packages let parse ~dir ~(lang : Lang.Instance.t) ~file = String_with_vars.set_decoding_env (Pform.Env.initial lang.version) @@ fields - @@ let+ name = field_o "name" Name.decode - and+ version = field_o "version" string - and+ info = Package.Info.decode () - and+ packages = multi_field "package" (Package.decode ~dir) - and+ explicit_extensions = - multi_field "using" - (let+ loc = loc - and+ name = located string - and+ ver = located Dune_lang.Syntax.Version.decode - and+ parse_args = capture in - (* We don't parse the arguments quite yet as we want to set the - version of extensions before parsing them. *) - Extension.instantiate ~dune_lang_ver:lang.version ~loc ~parse_args - name ver) - and+ implicit_transitive_deps = - field_o_b "implicit_transitive_deps" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 7)) - and+ wrapped_executables = - field_o_b "wrapped_executables" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) - and+ map_workspace_root = - field_o_b "map_workspace_root" - ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 7)) - and+ allow_approximate_merlin = - (* TODO DUNE4 remove this field from parsing *) - let+ loc = loc - and+ field = - field_b "allow_approximate_merlin" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 9)) - in - Option.some_if field loc - and+ executables_implicit_empty_intf = - field_o_b "executables_implicit_empty_intf" - ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 9)) - and+ accept_alternative_dune_file_name = - field_b "accept_alternative_dune_file_name" - ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) - and+ () = Dune_lang.Versioned_file.no_more_lang - and+ generate_opam_files = - field_o_b "generate_opam_files" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 10)) - and+ use_standard_c_and_cxx_flags = - field_o_b "use_standard_c_and_cxx_flags" - ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 8)) - and+ dialects = - multi_field "dialect" - (Dune_lang.Syntax.since Stanza.syntax (1, 11) - >>> located Dialect.decode) - and+ explicit_js_mode = - field_o_b "explicit_js_mode" - ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) - and+ format_config = Format_config.field ~since:(2, 0) - and+ subst_config = Subst_config.field ~since:(3, 0) - and+ strict_package_deps = - field_o_b "strict_package_deps" - ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 3)) - and+ cram = - Toggle.field "cram" ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 7)) - and+ expand_aliases_in_sandbox = - field_o_b "expand_aliases_in_sandbox" - ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) - and+ opam_file_location = - field_o "opam_file_location" - (Dune_lang.Syntax.since Stanza.syntax (3, 8) - >>> enum - [ ("relative_to_project", `Relative_to_project) - ; ("inside_opam_directory", `Inside_opam_directory) - ]) - in - fun (opam_packages : (Loc.t * Package.t Memo.t) Package.Name.Map.t) -> - let opam_file_location = - Option.value opam_file_location - ~default:(opam_file_location_default ~lang) - in - let generate_opam_files = - Option.value ~default:false generate_opam_files - in - let open Memo.O in - let+ packages = - parse_packages name ~info ~dir ~version packages opam_file_location - ~generate_opam_files opam_packages - in - let name = - match name with - | Some n -> n - | None -> default_name ~dir ~packages - in - let explicit_extensions = explicit_extensions_map explicit_extensions in - let parsing_context, stanza_parser, extension_args = - interpret_lang_and_extensions ~lang ~explicit_extensions - in - let implicit_transitive_deps = - Option.value implicit_transitive_deps - ~default:(implicit_transitive_deps_default ~lang) - in - let wrapped_executables = - Option.value wrapped_executables - ~default:(wrapped_executables_default ~lang) - in - let map_workspace_root = - Option.value map_workspace_root - ~default:(map_workspace_root_default ~lang) - in - let executables_implicit_empty_intf = - Option.value executables_implicit_empty_intf - ~default:(executables_implicit_empty_intf_default ~lang) - in - let strict_package_deps = - Option.value strict_package_deps - ~default:(strict_package_deps_default ~lang) - in - let dune_version = lang.version in - let explicit_js_mode = - Option.value explicit_js_mode ~default:(explicit_js_mode_default ~lang) - in - let use_standard_c_and_cxx_flags = - match use_standard_c_and_cxx_flags with - | None -> use_standard_c_and_cxx_flags_default ~lang - | some -> some - in - let cram = - match cram with - | None -> cram_default ~lang - | Some t -> Toggle.enabled t - in - let expand_aliases_in_sandbox = - Option.value expand_aliases_in_sandbox - ~default:(expand_aliases_in_sandbox_default ~lang) - in - let root = dir in - let file_key = File_key.make ~name ~root in - let dialects = - let dialects = - match String.Map.find explicit_extensions Melange_syntax.name with - | Some extension -> (extension.loc, Dialect.rescript) :: dialects - | None -> dialects - in - List.fold_left dialects ~init:Dialect.DB.builtin - ~f:(fun dialects (loc, dialect) -> - Dialect.DB.add dialects ~loc dialect) - in - { name - ; file_key - ; root - ; version - ; dune_version - ; info - ; packages - ; stanza_parser - ; project_file = file - ; extension_args - ; parsing_context - ; implicit_transitive_deps - ; wrapped_executables - ; map_workspace_root - ; executables_implicit_empty_intf - ; accept_alternative_dune_file_name - ; generate_opam_files - ; use_standard_c_and_cxx_flags - ; dialects - ; explicit_js_mode - ; format_config - ; subst_config - ; strict_package_deps - ; allow_approximate_merlin - ; cram - ; expand_aliases_in_sandbox - ; opam_file_location - } + @@ + let+ name = field_o "name" Name.decode + and+ version = field_o "version" string + and+ info = Package.Info.decode () + and+ packages = multi_field "package" (Package.decode ~dir) + and+ explicit_extensions = + multi_field "using" + (let+ loc = loc + and+ name = located string + and+ ver = located Dune_lang.Syntax.Version.decode + and+ parse_args = capture in + (* We don't parse the arguments quite yet as we want to set the + version of extensions before parsing them. *) + Extension.instantiate ~dune_lang_ver:lang.version ~loc ~parse_args name + ver) + and+ implicit_transitive_deps = + field_o_b "implicit_transitive_deps" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 7)) + and+ wrapped_executables = + field_o_b "wrapped_executables" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) + and+ map_workspace_root = + field_o_b "map_workspace_root" + ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 7)) + and+ allow_approximate_merlin = + (* TODO DUNE4 remove this field from parsing *) + let+ loc = loc + and+ field = + field_b "allow_approximate_merlin" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 9)) + in + Option.some_if field loc + and+ executables_implicit_empty_intf = + field_o_b "executables_implicit_empty_intf" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 9)) + and+ accept_alternative_dune_file_name = + field_b "accept_alternative_dune_file_name" + ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) + and+ () = Dune_lang.Versioned_file.no_more_lang + and+ generate_opam_files = + field_o_b "generate_opam_files" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 10)) + and+ use_standard_c_and_cxx_flags = + field_o_b "use_standard_c_and_cxx_flags" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 8)) + and+ dialects = + multi_field "dialect" + (Dune_lang.Syntax.since Stanza.syntax (1, 11) >>> located Dialect.decode) + and+ explicit_js_mode = + field_o_b "explicit_js_mode" + ~check:(Dune_lang.Syntax.since Stanza.syntax (1, 11)) + and+ format_config = Format_config.field ~since:(2, 0) + and+ subst_config = Subst_config.field ~since:(3, 0) + and+ strict_package_deps = + field_o_b "strict_package_deps" + ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 3)) + and+ cram = + Toggle.field "cram" ~check:(Dune_lang.Syntax.since Stanza.syntax (2, 7)) + and+ expand_aliases_in_sandbox = + field_o_b "expand_aliases_in_sandbox" + ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) + and+ opam_file_location = + field_o "opam_file_location" + (Dune_lang.Syntax.since Stanza.syntax (3, 8) + >>> enum + [ ("relative_to_project", `Relative_to_project) + ; ("inside_opam_directory", `Inside_opam_directory) + ]) + in + fun (opam_packages : (Loc.t * Package.t Memo.t) Package.Name.Map.t) -> + let opam_file_location = + Option.value opam_file_location + ~default:(opam_file_location_default ~lang) + in + let generate_opam_files = Option.value ~default:false generate_opam_files in + let open Memo.O in + let+ packages = + parse_packages name ~info ~dir ~version packages opam_file_location + ~generate_opam_files opam_packages + in + let name = + match name with + | Some n -> n + | None -> default_name ~dir ~packages + in + let explicit_extensions = explicit_extensions_map explicit_extensions in + let parsing_context, stanza_parser, extension_args = + interpret_lang_and_extensions ~lang ~explicit_extensions + in + let implicit_transitive_deps = + Option.value implicit_transitive_deps + ~default:(implicit_transitive_deps_default ~lang) + in + let wrapped_executables = + Option.value wrapped_executables + ~default:(wrapped_executables_default ~lang) + in + let map_workspace_root = + Option.value map_workspace_root + ~default:(map_workspace_root_default ~lang) + in + let executables_implicit_empty_intf = + Option.value executables_implicit_empty_intf + ~default:(executables_implicit_empty_intf_default ~lang) + in + let strict_package_deps = + Option.value strict_package_deps + ~default:(strict_package_deps_default ~lang) + in + let dune_version = lang.version in + let explicit_js_mode = + Option.value explicit_js_mode ~default:(explicit_js_mode_default ~lang) + in + let use_standard_c_and_cxx_flags = + match use_standard_c_and_cxx_flags with + | None -> use_standard_c_and_cxx_flags_default ~lang + | some -> some + in + let cram = + match cram with + | None -> cram_default ~lang + | Some t -> Toggle.enabled t + in + let expand_aliases_in_sandbox = + Option.value expand_aliases_in_sandbox + ~default:(expand_aliases_in_sandbox_default ~lang) + in + let root = dir in + let file_key = File_key.make ~name ~root in + let dialects = + let dialects = + match String.Map.find explicit_extensions Melange_syntax.name with + | Some extension -> (extension.loc, Dialect.rescript) :: dialects + | None -> dialects + in + List.fold_left dialects ~init:Dialect.DB.builtin + ~f:(fun dialects (loc, dialect) -> Dialect.DB.add dialects ~loc dialect) + in + { name + ; file_key + ; root + ; version + ; dune_version + ; info + ; packages + ; stanza_parser + ; project_file = file + ; extension_args + ; parsing_context + ; implicit_transitive_deps + ; wrapped_executables + ; map_workspace_root + ; executables_implicit_empty_intf + ; accept_alternative_dune_file_name + ; generate_opam_files + ; use_standard_c_and_cxx_flags + ; dialects + ; explicit_js_mode + ; format_config + ; subst_config + ; strict_package_deps + ; allow_approximate_merlin + ; cram + ; expand_aliases_in_sandbox + ; opam_file_location + } let load_dune_project ~dir opam_packages : t Memo.t = let file = Path.Source.relative dir filename in diff --git a/src/dune_rules/package.ml b/src/dune_rules/package.ml index a82a55d49439..4440eef595bf 100644 --- a/src/dune_rules/package.ml +++ b/src/dune_rules/package.ml @@ -27,6 +27,9 @@ module Name = struct module Infix = Comparator.Operators (String) module Map_traversals = Memo.Make_map_traversals (Map) + + let decode_strict = + Dune_lang.Decoder.map ~f:Strict.to_package_name Strict.decode end module Id = struct @@ -573,6 +576,9 @@ let encode (name : Name.t) in list sexp (string "package" :: fields) +let decode_name ~version = + if version >= (3, 11) then Name.decode_strict else Name.decode + let decode ~dir = let open Dune_lang.Decoder in let name_map syntax of_list_map to_string name decode print_value error_msg = @@ -587,51 +593,52 @@ let decode ~dir = ] in fields - @@ let+ loc = loc - and+ name = field "name" Name.decode - and+ synopsis = field_o "synopsis" string - and+ description = field_o "description" string - and+ version = - field_o "version" (Dune_lang.Syntax.since Stanza.syntax (2, 5) >>> string) - and+ depends = field ~default:[] "depends" (repeat Dependency.decode) - and+ conflicts = field ~default:[] "conflicts" (repeat Dependency.decode) - and+ depopts = field ~default:[] "depopts" (repeat Dependency.decode) - and+ info = Info.decode ~since:(2, 0) () - and+ tags = field "tags" (enter (repeat string)) ~default:[] - and+ deprecated_package_names = - name_map - (Dune_lang.Syntax.since Stanza.syntax (2, 0)) - Name.Map.of_list_map Name.to_string "deprecated_package_names" - (located Name.decode) Loc.to_file_colon_line "Deprecated package name" - and+ sites = - name_map - (Dune_lang.Syntax.since Stanza.syntax (2, 8)) - Site.Map.of_list_map Site.to_string "sites" - (pair Section.decode Site.decode) - Section.to_string "Site location name" - and+ allow_empty = - field_b "allow_empty" - ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) - and+ lang_version = Dune_lang.Syntax.get_exn Stanza.syntax in - let allow_empty = lang_version < (3, 0) || allow_empty in - let id = { Id.name; dir } in - let opam_file = Id.default_opam_file id in - { id - ; loc - ; synopsis - ; description - ; depends - ; conflicts - ; depopts - ; info - ; version - ; has_opam_file = Exists false - ; tags - ; deprecated_package_names - ; sites - ; allow_empty - ; opam_file - } + @@ + let* version = Syntax.get_exn Stanza.syntax in + let+ loc = loc + and+ name = field "name" (decode_name ~version) + and+ synopsis = field_o "synopsis" string + and+ description = field_o "description" string + and+ version = + field_o "version" (Dune_lang.Syntax.since Stanza.syntax (2, 5) >>> string) + and+ depends = field ~default:[] "depends" (repeat Dependency.decode) + and+ conflicts = field ~default:[] "conflicts" (repeat Dependency.decode) + and+ depopts = field ~default:[] "depopts" (repeat Dependency.decode) + and+ info = Info.decode ~since:(2, 0) () + and+ tags = field "tags" (enter (repeat string)) ~default:[] + and+ deprecated_package_names = + name_map + (Dune_lang.Syntax.since Stanza.syntax (2, 0)) + Name.Map.of_list_map Name.to_string "deprecated_package_names" + (located Name.decode) Loc.to_file_colon_line "Deprecated package name" + and+ sites = + name_map + (Dune_lang.Syntax.since Stanza.syntax (2, 8)) + Site.Map.of_list_map Site.to_string "sites" + (pair Section.decode Site.decode) + Section.to_string "Site location name" + and+ allow_empty = + field_b "allow_empty" ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 0)) + and+ lang_version = Dune_lang.Syntax.get_exn Stanza.syntax in + let allow_empty = lang_version < (3, 0) || allow_empty in + let id = { Id.name; dir } in + let opam_file = Id.default_opam_file id in + { id + ; loc + ; synopsis + ; description + ; depends + ; conflicts + ; depopts + ; info + ; version + ; has_opam_file = Exists false + ; tags + ; deprecated_package_names + ; sites + ; allow_empty + ; opam_file + } let dyn_of_opam_file = let open Dyn in diff --git a/test/blackbox-tests/test-cases/package-name-strict.t b/test/blackbox-tests/test-cases/package-name-strict.t new file mode 100644 index 000000000000..7402619f9589 --- /dev/null +++ b/test/blackbox-tests/test-cases/package-name-strict.t @@ -0,0 +1,55 @@ +Version check: + + $ cat > dune-project << EOF + > (lang dune 3.10) + > (package + > (name some&name) + > (allow_empty)) + > EOF + $ dune build + +Validation: + + $ test() { + > cat > dune-project << EOF + > (lang dune 3.11) + > (package + > (name $1) + > (allow_empty)) + > EOF + > dune build + > } + + $ test 'some&name' + File "dune-project", line 3, characters 7-16: + 3 | (name some&name) + ^^^^^^^^^ + Error: "some&name" is an invalid package name. + Package names start with a letter and can contain letters, numbers, '-', '_' + and '+' + Hint: some_name would be a correct package name + [1] + +Leading invalid characters are removed: + + $ test '0test' + File "dune-project", line 3, characters 7-12: + 3 | (name 0test) + ^^^^^ + Error: "0test" is an invalid package name. + Package names start with a letter and can contain letters, numbers, '-', '_' + and '+' + Hint: test would be a correct package name + [1] + +When all characters are removed, a valid name is suggested: + + $ test '0' + File "dune-project", line 3, characters 7-8: + 3 | (name 0) + ^ + Error: "0" is an invalid package name. + Package names start with a letter and can contain letters, numbers, '-', '_' + and '+' + Hint: a would be a correct package name + [1]