package core_kernel

  1. Overview
  2. Docs
Industrial strength alternative to OCaml's standard library

Install

Dune Dependency

Authors

Maintainers

Sources

v0.17.0.tar.gz
sha256=fd2b8c6715794df7a810a62b226f53720f211cd344b4afc9fab0498796d6b466

doc/src/core_kernel.version_util/version_util.ml.html

Source file version_util.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
open! Core

(* The [generated_build_info ()] string can be:

   - The empty string, from the default C function. This indicates that the build system
     does not support build info for this executable, e.g. because it's a test runner.

   - A printed sexp, from the C function generated by the build system, which is parsable
     by the [Build_info.t] type below. *)
external generated_build_info : unit -> string = "generated_build_info"

(* The [generated_hg_version ()] can be:

   - The empty string, from the default C function. This indicates that the build system
     does not support version info for this executable, e.g. because it's a test runner.

   - "NO_VERSION_UTIL" from the C function generated by the build system; or

   - "repo1 rev40\nrepo2 rev40" from the C function generated by the build system.

   The last two are prefixed by the [Version_util.start_marker]. When the prefix is
   present, there is also enough padding for ~4K worth of data. This allows us to rewrite
   binaries to insert the version util after linking.
*)
external generated_hg_version : unit -> string = "generated_hg_version"

(** Make sure to update [bin/generate_static_string_c_code.sh] too if you are changing
    these constants. *)
module Version_util_section = Section.Make (struct
  let name = "version_util"
  let length_including_start_marker = 4096

  (* BEFORE CHANGING: Please note the bidirectional version compatibility guarantee
       granted in the mli file for [Expert.get_version_util]. If we ever need to change the
       version util format, we should update the code to be able to read both the old and
       new formats, then wait a month, then change the write function to only write the new
       format. The old and new formats can be distinguished by minting a new [start_marker]
       for the new format.
    *)
  let start_marker =
    (* This trick is to prevent the marker from occurring verbatim in the binary that uses
         [Expert.insert_version_util], so that we don't by accident rewrite our own code.

         [opaque_identity] is used to prevent the compiler from converting this computation
         into a literal, thus undoing this trick. We could split the marker in half instead,
         but that would make grepping hard for humans.
         Grep in the tree to see the place that generates this. *)
    (Sys.opaque_identity ( ^ )) "rUb71QgfHXXwnBWBoJfb0Sa3R60vihdV" ":"
  ;;
end)

(** Make sure to update [bin/generate_static_string_c_code.sh] too if you are changing
    these constants. *)
module Build_info_section = Section.Make (struct
  let name = "build info"
  let length_including_start_marker = 4096

  let start_marker =
    (* Same trick as in [Version_util_section]. *)
    (Sys.opaque_identity ( ^ )) "vNxXpiccvPI9MHVFJuNwNxj8eu9W5KCB" ":"
  ;;
end)

(* BEFORE CHANGING: Note version compatibility guarantee above. *)
let parse_generated_hg_version = function
  | "" -> [ "NO_VERSION_UTIL" ]
  | generated_hg_version ->
    generated_hg_version
    |> String.chop_suffix_if_exists ~suffix:"\n"
    |> Version_util_section.chop_start_marker_if_exists
    |> String.split ~on:'\n'
    |> List.map ~f:(fun line ->
         match String.rsplit2 line ~on:' ' with
         | None -> line (* no version util *)
         | Some (repo, rev_status) ->
           (* For compability with downstream tools that might rely on this output format,
           and with [Version.parse].*)
           String.concat
             [ repo
             ; "_"
             ; String.prefix rev_status 12
             ; (* The revision can have a one-character '+' suffix. Keep it. *)
               (if String.length rev_status mod 2 = 1
                then String.suffix rev_status 1
                else "")
             ])
;;

let version_list = parse_generated_hg_version (generated_hg_version ())
let version = String.concat version_list ~sep:" "

module Version = struct
  type t =
    { repo : string
    ; version : string
    }
  [@@deriving compare, sexp_of]

  let parse1 version =
    match String.rsplit2 version ~on:'_' with
    | None -> error_s [%message "Could not parse version" version]
    | Some (repo, version) -> Ok { repo; version }
  ;;

  let parse_list l =
    (* We might get multiple such lines if we have multiple repos *)
    if List.exists l ~f:(String.( = ) "NO_VERSION_UTIL")
    then Ok None
    else
      List.map l ~f:parse1 |> Or_error.combine_errors |> Or_error.map ~f:(fun x -> Some x)
  ;;

  let parse_lines versions = parse_list (String.split_lines versions)
  let current_version () = ok_exn (parse_list version_list)

  let present = function
    | None -> error_s [%sexp "executable built without version util"]
    | Some x -> Ok x
  ;;

  let parse_list_present x = Or_error.bind ~f:present (parse_list x)
  let parse_lines_present x = Or_error.bind ~f:present (parse_lines x)
  let current_version_present () = present (current_version ())
end

module Expert = struct
  (* BEFORE CHANGING: Please note the bidirectional version compatibility guarantee
     granted in the mli file. *)
  let get_version_util ~contents_of_exe =
    let%map.Option section = Version_util_section.get ~contents_of_exe in
    String.concat ~sep:" " (parse_generated_hg_version section)
  ;;

  let text (versions_opt : Version.t list option) =
    match versions_opt with
    | None -> "NO_VERSION_UTIL"
    | Some versions ->
      if List.is_empty versions
      then failwith "version_util must include at least one repository";
      if List.contains_dup
           ~compare:String.compare
           (List.map versions ~f:(fun v -> v.repo))
      then failwith "version_util must not contain duplicate repositories";
      versions
      |> List.sort ~compare:Version.compare
      |> List.map ~f:(fun { repo; version } ->
           if not (String.mem repo '/')
           then failwith [%string "%{repo} doesn't look like a repo url"];
           (let version' = String.chop_suffix_if_exists version ~suffix:"+" in
            if (String.length version' = 40 || String.length version' = 64)
               && String.for_all version' ~f:Char.is_hex_digit_lower
            then ()
            else failwith [%string "%{version} doesn't look like a full hg version"]);
           repo ^ " " ^ version ^ "\n")
      |> String.concat
  ;;

  let raw_text v = Version_util_section.Expert.pad_with_at_least_one_nul_byte_exn (text v)

  let replace_version_util ~contents_of_exe versions_opt =
    (* Expert because we don't really want people to casually use this, so its contents
       can be trusted. *)
    Version_util_section.replace ~contents_of_exe ~data:(text versions_opt)
  ;;

  let parse_generated_hg_version = parse_generated_hg_version

  module Experimental = struct
    let get_build_info = Build_info_section.get

    let remove_build_info ~contents_of_exe =
      Build_info_section.replace ~contents_of_exe ~data:"NO_BUILD_INFO"
    ;;
  end

  module For_tests = struct
    let count_section_occurrences ~contents_of_exe =
      Version_util_section.count_occurrences ~contents_of_exe
      + Build_info_section.count_occurrences ~contents_of_exe
    ;;
  end
end

module Build_info = struct
  module Application_specific_fields = struct
    type t = Sexp.t String.Map.t [@@deriving sexp]
  end

  module Time_with_limited_parsing = struct
    type t = Time_float.t * Sexp.t

    let t_of_sexp sexp =
      let str = string_of_sexp sexp in
      try
        match String.chop_suffix str ~suffix:"Z" with
        | None -> failwith "zone must be Z"
        | Some rest ->
          (match String.lsplit2 rest ~on:' ' with
           | None -> failwith "time must contain one space between date and ofday"
           | Some (date, ofday) ->
             let date = Date.t_of_sexp (sexp_of_string date) in
             let ofday = Time_float.Ofday.t_of_sexp (sexp_of_string ofday) in
             Time_float.of_date_ofday date ofday ~zone:Time_float.Zone.utc, sexp)
      with
      | Sexplib.Conv.Of_sexp_error (e, _) | e ->
        raise (Sexplib.Conv.Of_sexp_error (e, sexp))
    ;;

    let sexp_of_t_ref = ref (fun (_, sexp) -> sexp)
    let sexp_of_t time = !sexp_of_t_ref time
    let epoch : t = Time_float.epoch, Atom "1970-01-01 00:00:00Z"
  end

  type t =
    { username : string option [@sexp.option]
    ; hostname : string option [@sexp.option]
    ; kernel : string option [@sexp.option]
    ; build_time : Time_with_limited_parsing.t option [@sexp.option]
    ; x_library_inlining : bool
    ; portable_int63 : bool
    ; dynlinkable_code : bool
    ; risk_system : bool [@sexp.default false]
    ; ocaml_version : string
    ; executable_path : string
    ; build_system : string
    ; allowed_projections : string list option [@sexp.option]
    ; with_fdo : (string * Md5.t option) option [@sexp.option]
    ; application_specific_fields : Application_specific_fields.t option [@sexp.option]
    }
  [@@deriving sexp]

  module Structured = struct
    type nonrec t =
      | Not_supported
      | Unset
      | Set of (string * Sexp.t * t)

    let t =
      Exn.handle_uncaught_and_exit (fun () ->
        match generated_build_info () with
        | "" -> Not_supported
        | non_empty_string ->
          (match Build_info_section.chop_start_marker_if_exists non_empty_string with
           | "NO_BUILD_INFO" -> Unset
           | str ->
             let sexp = Sexp.of_string str in
             let t = t_of_sexp sexp in
             Set (str, sexp, t)))
    ;;
  end

  let dummy : t =
    { username = None
    ; hostname = None
    ; kernel = None
    ; build_time = Some Time_with_limited_parsing.epoch
    ; x_library_inlining = false
    ; portable_int63 = true
    ; dynlinkable_code = false
    ; risk_system = false
    ; ocaml_version = ""
    ; executable_path = ""
    ; build_system = ""
    ; allowed_projections = None
    ; with_fdo = None
    ; application_specific_fields = None
    }
  ;;

  let build_system_supports_version_util =
    match Structured.t with
    | Not_supported -> false
    | Unset | Set _ -> true
  ;;

  let build_info_status =
    match Structured.t with
    | Not_supported -> `Not_supported
    | Unset -> `Unset
    | Set _ -> `Set
  ;;

  let build_info, build_info_as_sexp, t =
    match Structured.t with
    | Not_supported | Unset ->
      let t = dummy in
      let sexp = sexp_of_t t in
      let str = Sexp.to_string_mach sexp in
      str, sexp, t
    | Set tuple -> tuple
  ;;

  let { username
      ; hostname
      ; kernel
      ; build_time = build_time_and_sexp
      ; x_library_inlining
      ; portable_int63 = _
      ; dynlinkable_code
      ; risk_system = _
      ; ocaml_version
      ; executable_path
      ; build_system
      ; allowed_projections
      ; with_fdo
      ; application_specific_fields
      }
    =
    t
  ;;

  let build_time =
    match build_time_and_sexp with
    | None -> None
    | Some (time, _sexp) -> Some time
  ;;

  let reprint_build_info sexp_of_time =
    Ref.set_temporarily
      Time_with_limited_parsing.sexp_of_t_ref
      (fun (time, _) -> sexp_of_time time)
      ~f:(fun () -> Sexp.to_string (sexp_of_t t))
  ;;
end

include Build_info

let compiled_for_speed = x_library_inlining && not dynlinkable_code

module For_tests = struct
  let build_info_status = Build_info.build_info_status
  let parse_generated_hg_version = parse_generated_hg_version
end

let arg_spec =
  [ ( "-version"
    , Arg.Unit
        (fun () ->
          List.iter version_list ~f:print_endline;
          exit 0)
    , " Print the hg revision of this build and exit" )
  ; ( "-build_info"
    , Arg.Unit
        (fun () ->
          print_endline build_info;
          exit 0)
    , " Print build info as sexp and exit" )
  ]
;;

module Private__For_version_util_async = struct
  let version_util_start_marker = Version_util_section.Expert.start_marker
  let parse_generated_hg_version = parse_generated_hg_version
  let raw_text = Expert.raw_text
end
OCaml

Innovation. Community. Security.