unikernel/duniverse/dune_/bin/subst.ml

@@ -0,0 +1,538 @@
+open Import
+
+let is_path_a_source_file path =
+  match Path.extension (Path.source path) with
+  | ".flv"
+  | ".gif"
+  | ".ico"
+  | ".jpeg"
+  | ".jpg"
+  | ".mov"
+  | ".mp3"
+  | ".mp4"
+  | ".otf"
+  | ".pdf"
+  | ".png"
+  | ".ttf"
+  | ".woff" -> false
+  | _ -> true
+;;
+
+let is_kind_a_source_file path =
+  match Path.stat (Path.source path) with
+  | Ok st -> st.st_kind = S_REG
+  | Error (ENOENT, "stat", _) ->
+    (* broken symlink *)
+    false
+  | Error e -> Unix_error.Detailed.raise e
+;;
+
+let is_a_source_file path = is_path_a_source_file path && is_kind_a_source_file path
+
+let subst_string s path ~map =
+  let len = String.length s in
+  let longest_var = String.longest (String.Map.keys map) in
+  let double_percent_len = String.length "%%" in
+  let loc_of_offset ~ofs ~len =
+    let rec loop lnum bol i =
+      if i = ofs
+      then (
+        let pos =
+          { Lexing.pos_fname = Path.to_string path
+          ; pos_cnum = i
+          ; pos_lnum = lnum
+          ; pos_bol = bol
+          }
+        in
+        Loc.create ~start:pos ~stop:{ pos with pos_cnum = pos.pos_cnum + len })
+      else (
+        match s.[i] with
+        | '\n' -> loop (lnum + 1) (i + 1) (i + 1)
+        | _ -> loop lnum bol (i + 1))
+    in
+    loop 1 0 0
+  in
+  let rec loop i acc =
+    if i = len
+    then acc
+    else (
+      match s.[i] with
+      | '%' -> after_percent (i + 1) acc
+      | _ -> loop (i + 1) acc)
+  and after_percent i acc =
+    if i = len
+    then acc
+    else (
+      match s.[i] with
+      | '%' -> after_double_percent ~start:(i - 1) (i + 1) acc
+      | _ -> loop (i + 1) acc)
+  and after_double_percent ~start i acc =
+    if i = len
+    then acc
+    else (
+      match s.[i] with
+      | '%' -> after_double_percent ~start:(i - 1) (i + 1) acc
+      | 'A' .. 'Z' | '_' -> in_var ~start (i + 1) acc
+      | _ -> loop (i + 1) acc)
+  and in_var ~start i acc =
+    if i - start > longest_var + double_percent_len
+    then loop i acc
+    else if i = len
+    then acc
+    else (
+      match s.[i] with
+      | '%' -> end_of_var ~start (i + 1) acc
+      | 'A' .. 'Z' | '_' -> in_var ~start (i + 1) acc
+      | _ -> loop (i + 1) acc)
+  and end_of_var ~start i acc =
+    if i = len
+    then acc
+    else (
+      match s.[i] with
+      | '%' ->
+        let var = String.sub s ~pos:(start + 2) ~len:(i - start - 3) in
+        (match String.Map.find map var with
+         | None -> in_var ~start:(i - 1) (i + 1) acc
+         | Some (Ok repl) ->
+           let acc = (start, i + 1, repl) :: acc in
+           loop (i + 1) acc
+         | Some (Error msg) ->
+           let loc = loc_of_offset ~ofs:start ~len:(i + 1 - start) in
+           User_error.raise ~loc [ Pp.text msg ])
+      | _ -> loop (i + 1) acc)
+  in
+  match List.rev (loop 0 []) with
+  | [] -> None
+  | repls ->
+    let result_len =
+      List.fold_left repls ~init:(String.length s) ~f:(fun acc (a, b, repl) ->
+        acc - (b - a) + String.length repl)
+    in
+    let buf = Buffer.create result_len in
+    let pos =
+      List.fold_left repls ~init:0 ~f:(fun pos (a, b, repl) ->
+        Buffer.add_substring buf s pos (a - pos);
+        Buffer.add_string buf repl;
+        b)
+    in
+    Buffer.add_substring buf s pos (len - pos);
+    Some (Buffer.contents buf)
+;;
+
+let subst_file path ~map opam_package_files =
+  match Io.with_file_in (Path.source path) ~f:Io.read_all_unless_large with
+  | Error () ->
+    let hints =
+      if Sys.word_size = 32
+      then
+        [ Pp.textf
+            "Dune has been built as a 32-bit binary so the maximum size \"dune subst\" \
+             can operate on is 16MiB."
+        ]
+      else []
+    in
+    User_warning.emit
+      ~hints
+      [ Pp.textf "Ignoring large file: %s" (Path.Source.to_string path) ]
+  | Ok s ->
+    let version =
+      if Path.Source.Set.mem opam_package_files path
+      then (
+        try
+          subst_string ("version: \"%%" ^ "VERSION_NUM" ^ "%%\"") ~map (Path.source path)
+        with
+        | User_error.E _ -> None)
+      else None
+    in
+    let path = Path.source path in
+    let subst = subst_string s ~map path in
+    let contents =
+      match version, subst with
+      | None, None -> None
+      | Some x, None -> Some (x ^ "\n" ^ s)
+      | None, Some x -> Some x
+      | Some x, Some y -> Some (x ^ "\n" ^ y)
+    in
+    Option.iter contents ~f:(Io.write_file path)
+;;
+
+(* Extending the Dune_project APIs, but adding capability to modify *)
+module Dune_project = struct
+  include Dune_project
+
+  type 'a simple_field =
+    { loc : Loc.t
+    ; loc_of_arg : Loc.t
+    ; arg : 'a
+    }
+
+  type t =
+    { contents : string
+    ; project_file : Path.Source.t
+    ; name : Package.Name.t simple_field option
+    ; version : string simple_field option
+    ; project : Dune_project.t
+    }
+
+  let filename = Path.Source.of_string Dune_project.filename
+
+  let load ~dir ~files ~infer_from_opam_files =
+    let open Memo.O in
+    let+ project =
+      Dune_project.load
+        ~dir
+        ~files
+        ~infer_from_opam_files
+        ~load_opam_file_with_contents:Dune_pkg.Opam_file.load_opam_file_with_contents
+    in
+    let open Option.O in
+    let* project = project in
+    let* project_file = Dune_project.file project in
+    let project_file = project_file in
+    let contents = Io.read_file (Path.source project_file) in
+    let sexp =
+      let lb = Lexbuf.from_string contents ~fname:(Path.Source.to_string project_file) in
+      Dune_lang.Parser.parse lb ~mode:Many_as_one
+    in
+    let parser =
+      let open Dune_lang.Decoder in
+      let simple_field name arg =
+        let+ loc, x = located (field_o name (located arg)) in
+        Option.map x ~f:(fun (loc_of_arg, arg) -> { loc; loc_of_arg; arg })
+      in
+      enter
+        (fields
+           (let+ name = simple_field "name" Package.Name.decode
+            and+ version = simple_field "version" string
+            and+ () = junk_everything in
+            Some { contents; name; version; project; project_file }))
+    in
+    Dune_lang.Decoder.parse parser Univ_map.empty sexp
+  ;;
+
+  let project t = t.project
+
+  let subst t ~map ~version =
+    let s =
+      match version with
+      | None -> t.contents
+      | Some version ->
+        let replace_text start_ofs stop_ofs repl =
+          sprintf
+            "%s%s%s"
+            (String.sub t.contents ~pos:0 ~len:start_ofs)
+            repl
+            (String.sub
+               t.contents
+               ~pos:stop_ofs
+               ~len:(String.length t.contents - stop_ofs))
+        in
+        (match t.version with
+         | Some v ->
+           (* There is a [version] field, overwrite its argument *)
+           replace_text
+             (Loc.start v.loc_of_arg).pos_cnum
+             (Loc.stop v.loc_of_arg).pos_cnum
+             (Dune_lang.to_string (Dune_lang.atom_or_quoted_string version))
+         | None ->
+           let version_field =
+             Dune_lang.to_string
+               (List [ Dune_lang.atom "version"; Dune_lang.atom_or_quoted_string version ])
+             ^ "\n"
+           in
+           let ofs =
+             ref
+               (match t.name with
+                | Some { loc; _ } ->
+                  (* There is no [version] field but there is a [name] one, add
+                     the version after it *)
+                  (Loc.stop loc).pos_cnum
+                | None ->
+                  (* If all else fails, add the [version] field after the first
+                     line of the file *)
+                  0)
+           in
+           let len = String.length t.contents in
+           while !ofs < len && t.contents.[!ofs] <> '\n' do
+             incr ofs
+           done;
+           if !ofs < len && t.contents.[!ofs] = '\n'
+           then (
+             incr ofs;
+             replace_text !ofs !ofs version_field)
+           else replace_text !ofs !ofs ("\n" ^ version_field))
+    in
+    let s = Option.value (subst_string s ~map (Path.source filename)) ~default:s in
+    if s <> t.contents then Io.write_file (Path.source filename) s
+  ;;
+end
+
+let make_watermark_map ~commit ~version ~dune_project ~info =
+  let dune_project = Dune_project.project dune_project in
+  let version =
+    match version with
+    | Some _ -> version
+    | None -> Option.map ~f:Package_version.to_string (Dune_project.version dune_project)
+  in
+  let version_num =
+    let open Option.O in
+    let+ version = version in
+    Option.value ~default:version (String.drop_prefix version ~prefix:"v")
+  in
+  let name = Dune_project.name dune_project in
+  (* XXX these error messages aren't particularly good as these values do not
+     necessarily come from the project file. It's possible for them to be
+     defined in the .opam file directly*)
+  let make_value name = function
+    | None -> Error (sprintf "variable %S not found in dune-project file" name)
+    | Some value -> Ok value
+  in
+  let make_separated name sep = function
+    | None -> Error (sprintf "variable %S not found in dune-project file" name)
+    | Some value -> Ok (String.concat ~sep value)
+  in
+  let make_dev_repo_value = function
+    | Some (Source_kind.Host h) -> Ok (Source_kind.Host.homepage h)
+    | Some (Source_kind.Url url) -> Ok url
+    | None -> Error (sprintf "variable dev-repo not found in dune-project file")
+  in
+  let make_version = function
+    | Some s -> Ok s
+    | None -> Error "repository does not contain any version information"
+  in
+  String.Map.of_list_exn
+    [ "NAME", Ok (Dune_project_name.to_string_hum name)
+    ; "VERSION", make_version version
+    ; "VERSION_NUM", make_version version_num
+    ; ( "VCS_COMMIT_ID"
+      , match commit with
+        | None -> Error "repository does not contain any commits"
+        | Some s -> Ok s )
+    ; "PKG_MAINTAINER", make_separated "maintainer" ", " @@ Package_info.maintainers info
+    ; "PKG_AUTHORS", make_separated "authors" ", " @@ Package_info.authors info
+    ; "PKG_HOMEPAGE", make_value "homepage" @@ Package_info.homepage info
+    ; "PKG_ISSUES", make_value "bug-reports" @@ Package_info.bug_reports info
+    ; "PKG_DOC", make_value "doc" @@ Package_info.documentation info
+    ; "PKG_LICENSE", make_separated "license" ", " @@ Package_info.license info
+    ; "PKG_REPO", make_dev_repo_value @@ Package_info.source info
+    ]
+;;
+
+let subst vcs =
+  let open Memo.O in
+  (match vcs with
+   | Some vcs ->
+     let+ version = Vcs.describe vcs
+     and+ commit_id = Vcs.commit_id vcs
+     and+ files = Vcs.files vcs in
+     Some (version, commit_id, files)
+   | None ->
+     let* root = Source_tree.root () in
+     let project = Source_tree.Dir.project root in
+     if Dune_project.dune_version project < (3, 17)
+     then Memo.return None
+     else
+       let+ files =
+         let module Map_reduce =
+           Source_tree.Dir.Make_map_reduce (Memo) (Monoid.Union (Path.Source.Set))
+         in
+         Source_tree.root ()
+         >>= Map_reduce.map_reduce
+               ~traverse:Source_dir_status.Set.all
+               ~trace_event_name:"Subst"
+               ~f:(fun dir ->
+                 Source_tree.Dir.filenames dir
+                 |> Filename.Set.fold ~init:Path.Source.Set.empty ~f:(fun fname acc ->
+                   Path.Source.relative (Source_tree.Dir.path dir) fname
+                   |> Path.Source.Set.add acc)
+                 |> Memo.return)
+       in
+       Some (None, None, Path.Source.Set.to_list files))
+  >>| Option.bind ~f:(fun ((_, _, files) as s) ->
+    match files with
+    | [] -> None
+    | _ :: _ -> Some s)
+  >>= Memo.Option.iter ~f:(fun (version, commit, files) ->
+    let+ (dune_project : Dune_project.t) =
+      (* CR-soon rgrinberg: unify this check with the above version check *)
+      (let files =
+         (* Filter-out files form sub-directories *)
+         List.fold_left files ~init:String.Set.empty ~f:(fun acc fn ->
+           let fn = Path.source fn in
+           if Path.is_root (Path.parent_exn fn)
+           then String.Set.add acc (Path.to_string fn)
+           else acc)
+       in
+       Dune_project.load ~dir:Path.Source.root ~files ~infer_from_opam_files:true)
+      >>| function
+      | Some dune_project -> dune_project
+      | None ->
+        User_error.raise
+          ~loc:(Loc.in_dir (Path.source Path.Source.root))
+          [ Pp.text
+              "There is no dune-project file in the current directory, please add one \
+               with a (name <name>) field in it."
+          ]
+          ~hints:
+            [ Pp.concat
+                ~sep:Pp.space
+                [ User_message.command "dune subst"
+                ; Pp.text "must be executed from the root of the project."
+                ]
+              |> Pp.hovbox
+            ]
+    in
+    (let loc, subst_config = Dune_project.subst_config dune_project.project in
+     match subst_config with
+     | `Enabled -> ()
+     | `Disabled ->
+       User_error.raise
+         ~loc
+         [ Pp.concat
+             ~sep:Pp.space
+             [ User_message.command "dune subst"
+             ; Pp.text "has been disabled in this project. Any use of it is forbidden."
+             ]
+         ]
+         ~hints:
+           [ Pp.text
+               "If you wish to re-enable it, change to (subst enabled) in the \
+                dune-project file."
+           ]);
+    let info =
+      let loc, name =
+        match dune_project.name with
+        | None ->
+          User_error.raise
+            ~loc:(Loc.in_file (Path.source dune_project.project_file))
+            [ Pp.textf
+                "The project name is not defined, please add a (name <name>) field to \
+                 your dune-project file."
+            ]
+        | Some n -> n.loc_of_arg, n.arg
+      in
+      let package_named_after_project =
+        let packages = Dune_project.including_hidden_packages dune_project.project in
+        Package.Name.Map.find packages name
+      in
+      let metadata_from_dune_project () = Dune_project.info dune_project.project in
+      let metadata_from_matching_package () =
+        match package_named_after_project with
+        | Some pkg -> Ok (Package.info pkg)
+        | None ->
+          Error
+            (User_error.make
+               ~loc
+               [ Pp.textf "Package %s doesn't exist." (Package.Name.to_string name) ])
+      in
+      let version = Dune_project.dune_version dune_project.project in
+      if version >= (3, 0)
+      then metadata_from_dune_project ()
+      else if version >= (2, 8)
+      then (
+        match metadata_from_matching_package () with
+        | Ok p -> p
+        | Error _ -> metadata_from_dune_project ())
+      else User_error.ok_exn (metadata_from_matching_package ())
+    in
+    let watermarks = make_watermark_map ~commit ~version ~dune_project ~info in
+    Dune_project.subst ~map:watermarks ~version dune_project;
+    let opam_package_files =
+      Dune_project.packages dune_project.project
+      |> Package.Name.Map.fold ~init:Path.Source.Set.empty ~f:(fun package acc ->
+        Path.Source.Set.add acc (Package.opam_file package))
+    in
+    List.iter files ~f:(fun path ->
+      if is_a_source_file path && not (Path.Source.equal path Dune_project.filename)
+      then subst_file path ~map:watermarks opam_package_files))
+;;
+
+let subst () = Source_tree.nearest_vcs Path.Source.root |> Memo.bind ~f:subst |> Memo.run
+
+(** A string that is "3.20.2" but not expanded by [dune subst] *)
+let literal_version = "%%" ^ "VERSION%%"
+
+let doc = "Substitute watermarks in source files."
+
+let man =
+  let var name desc = `Blocks [ `Noblank; `P ("- $(b,%%" ^ name ^ "%%), " ^ desc) ] in
+  let opam field =
+    var
+      ("PKG_" ^ String.uppercase field)
+      ("contents of the $(b," ^ field ^ ":) field from the opam file")
+  in
+  [ `S "DESCRIPTION"
+  ; `P
+      {|Substitute $(b,%%ID%%) strings in source files, in a similar fashion to
+          what topkg does in the default configuration.|}
+  ; `P
+      ({|This command is only meant to be called when a user pins a package to
+          its development version. Especially it replaces $(b,|}
+       ^ literal_version
+       ^ {|) strings by the version obtained from the vcs. Currently only git is
+            supported and the version is obtained from the output of:|}
+      )
+  ; `Pre {|  \$ git describe --always --dirty --abbrev=7|}
+  ; `P
+      {|$(b,dune subst) substitutes the variables that topkg substitutes with
+          the default configuration:|}
+  ; var "NAME" "the name of the project (from the dune-project file)"
+  ; var "VERSION" "output of $(b,git describe --always --dirty --abbrev=7)"
+  ; var
+      "VERSION_NUM"
+      ("same as $(b,"
+       ^ literal_version
+       ^ ") but with a potential leading 'v' or 'V' dropped")
+  ; var "VCS_COMMIT_ID" "commit hash from the vcs"
+  ; opam "maintainer"
+  ; opam "authors"
+  ; opam "homepage"
+  ; opam "issues"
+  ; opam "doc"
+  ; opam "license"
+  ; opam "repo"
+  ; `P
+      {|In order to call $(b,dune subst) when your package is pinned, add this line
+          to the $(b,build:) field of your opam file:|}
+  ; `Pre {|  [dune "subst"] {pinned}|}
+  ; `P
+      {|Note that this command is meant to be called only from opam files and
+          behaves a bit differently from other dune commands. In particular it
+          doesn't try to detect the root and must be called from the root of
+          the project.|}
+  ; `Blocks Common.help_secs
+  ]
+;;
+
+let info = Cmd.info "subst" ~doc ~man
+
+let term =
+  let+ () = Common.build_info
+  and+ debug_backtraces = Common.debug_backtraces in
+  let config : Dune_config.t =
+    { Dune_config.default with
+      display = Dune_config.Display.quiet
+    ; concurrency = Fixed 1
+    }
+  in
+  (* We have to do this because scanning the source tree evaluates [-p].
+     That's because [-p] is needed to interpret packages in dune projects
+     correctly. It should not be necessary, so we should probably make the
+     package loading lazier. *)
+  Dune_rules.Only_packages.Clflags.set No_restriction;
+  Dune_engine.Clflags.debug_backtraces debug_backtraces;
+  Path.set_root (Path.External.cwd ());
+  Path.Build.set_build_dir (Path.Outside_build_dir.of_string Common.default_build_dir);
+  Dune_config.init config ~watch:false;
+  Log.init_disabled ();
+  Dune_engine.Scheduler.Run.go
+    ~on_event:(fun _ _ -> ())
+    (Dune_config.for_scheduler
+       config
+       ~watch_exclusions:[]
+       None
+       ~print_ctrl_c_warning:false)
+    subst
+;;
+
+let command = Cmd.v info term