package core

  1. Overview
  2. Docs
package core
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file zone.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
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
(* Functions for parsing time zone database files (zic files).

   A time zone file consists (conceptually - the representation is more
   compact) of an ordered list of (Time.t * [local_time_type]) that mark
   the boundaries (marked from the epoch) at which various time adjustment
   regimes are in effect.  This can also be thought of as breaking down all
   time past the epoch into ranges with a [local_time_type] that describes the
   offset from GMT to apply to each range to get local time.
*)

open Import
open Std_internal
open! Int.Replace_polymorphic_compare
include Zone_intf

exception Invalid_file_format of string [@@deriving sexp]

module Stable = struct
  module Full_data = struct
    module V1 = struct
      module Index = struct
        type t = int

        let next = Int.succ
        let prev = Int.pred
        let before_first_transition = -1

        (* Some existing clients expect [index >= 0], so we never serialize a negative
           index. This conversion can be removed if new stable versions are minted. *)
        let to_external t = max 0 t

        (* When the index of a time zone with no transitions is converted via to_external,
           its value becomes 0 even though its transition array is empty (and it should
           have been -1). When the converted value is changed back to a Zone.t through
           of_external, returning this value for its index could result in unsafe array
           accesses to the transition array of the zone (since there is no transition at
           index 0). Also, it does not make sense to keep the converted index because it
           is intended to be a mutable value used for caching. So of_external always sets
           the index to -1, which is a safe value. *)
        let of_external (_ : t) = -1

        include
          Binable.Of_binable_without_uuid [@alert "-legacy"]
            (Int)
            (struct
              type t = int

              let to_binable = to_external
              let of_binable = of_external
            end)

        include
          Sexpable.Of_sexpable
            (Int)
            (struct
              type t = int

              let to_sexpable = to_external
              let of_sexpable = of_external
            end)
      end

      module Regime = struct
        type t =
          { utc_offset_in_seconds : Int63.Stable.V1.t
          ; is_dst : bool
          ; abbrv : string
          }
        [@@deriving bin_io, sexp]
      end

      (* holds information about when leap seconds should be applied - unused
         because we are translating based on a epoch system clock (see the Core_zone
         documentation). *)
      module Leap_second = struct
        type t =
          { time_in_seconds_since_epoch : Int63.Stable.V1.t
          ; seconds : int
          }
        [@@deriving bin_io, sexp]
      end

      module Transition = struct
        type t =
          { start_time_in_seconds_since_epoch : Int63.Stable.V1.t
          ; new_regime : Regime.t
          }
        [@@deriving bin_io, sexp]
      end

      type t =
        { name : string
        ; original_filename : string option
        ;
          digest : Md5.As_binary_string.t option
        ; transitions : Transition.t array
        ; (* caches the index of the last transition we used to make lookups faster *)
          mutable last_regime_index : Index.t
        ; default_local_time_type : Regime.t
        ; leap_seconds : Leap_second.t list
        }
      [@@deriving bin_io, sexp]

      (* this relies on zones with the same name having the same transitions *)
      let compare t1 t2 = String.compare t1.name t2.name
      let original_filename zone = zone.original_filename
      let digest zone = zone.digest

      module Zone_file : sig
        val input_tz_file : zonename:string -> filename:string -> t
      end = struct
        let bool_of_int i = i <> 0

        let input_long_as_int32 =
          let long = Bytes.create 4 in
          let int32_of_char chr = Int32.of_int_exn (int_of_char chr) in
          fun ic ->
            In_channel.really_input_exn ic ~buf:long ~pos:0 ~len:4;
            let sb1 = Int32.shift_left (int32_of_char (Bytes.get long 0)) 24 in
            let sb2 = Int32.shift_left (int32_of_char (Bytes.get long 1)) 16 in
            let sb3 = Int32.shift_left (int32_of_char (Bytes.get long 2)) 8 in
            let sb4 = int32_of_char (Bytes.get long 3) in
            Int32.bit_or (Int32.bit_or sb1 sb2) (Int32.bit_or sb3 sb4)
        ;;

        (* Note that this is only safe to use on numbers that will fit into a 31-bit
           int. UNIX timestamps won't, for example.  In our case this is only used
           to hold small numbers that are never interpreted as timestamps. *)
        let input_long_as_int ic = Int32.to_int_exn (input_long_as_int32 ic)
        let input_long_as_int63 ic = Int63.of_int32 (input_long_as_int32 ic)

        let input_long_long_as_int63 ic =
          let int63_of_char chr = Int63.of_int_exn (int_of_char chr) in
          let shift c bits = Int63.shift_left (int63_of_char c) bits in
          let long_long = Bytes.create 8 in
          In_channel.really_input_exn ic ~buf:long_long ~pos:0 ~len:8;
          let result = shift (Bytes.get long_long 0) 56 in
          let result = Int63.bit_or result (shift (Bytes.get long_long 1) 48) in
          let result = Int63.bit_or result (shift (Bytes.get long_long 2) 40) in
          let result = Int63.bit_or result (shift (Bytes.get long_long 3) 32) in
          let result = Int63.bit_or result (shift (Bytes.get long_long 4) 24) in
          let result = Int63.bit_or result (shift (Bytes.get long_long 5) 16) in
          let result = Int63.bit_or result (shift (Bytes.get long_long 6) 8) in
          let result = Int63.bit_or result (int63_of_char (Bytes.get long_long 7)) in
          result
        ;;

        let input_list ic ~len ~f =
          let rec loop c lst =
            if c > 0 then loop (c - 1) (f ic :: lst) else List.rev lst
          in
          loop len []
        ;;

        let input_array ic ~len ~f = Array.of_list (input_list ic ~len ~f)

        let input_regime ic =
          let utc_offset_in_seconds = input_long_as_int63 ic in
          let is_dst = bool_of_int (Option.value_exn (In_channel.input_byte ic)) in
          let abbrv_index = Option.value_exn (In_channel.input_byte ic) in
          let lt abbrv = { Regime.utc_offset_in_seconds; is_dst; abbrv } in
          lt, abbrv_index
        ;;

        let input_abbreviations ic ~len =
          let raw_abbrvs =
            input_list ic ~len ~f:(fun ic -> Option.value_exn (In_channel.input_char ic))
          in
          let buf = Buffer.create len in
          let _, indexed_abbrvs =
            List.fold raw_abbrvs ~init:(0, Map.Poly.empty) ~f:(fun (index, abbrvs) c ->
              match c with
              | '\000' ->
                let data = Buffer.contents buf in
                let next_index = index + String.length data + 1 in
                let abbrvs = Map.set abbrvs ~key:index ~data in
                Buffer.clear buf;
                next_index, abbrvs
              | c ->
                Buffer.add_char buf c;
                index, abbrvs)
          in
          if Buffer.length buf <> 0
          then
            raise
              (Invalid_file_format
                 "missing \000 terminating character in input_abbreviations");
          indexed_abbrvs
        ;;

        let input_tz_file_gen ~input_transition ~input_leap_second ic =
          let utc_local_count = input_long_as_int ic in
          let std_wall_count = input_long_as_int ic in
          let leap_count = input_long_as_int ic in
          let transition_count = input_long_as_int ic in
          let type_count = input_long_as_int ic in
          let abbrv_char_count = input_long_as_int ic in
          let transition_times =
            input_list ic ~f:input_transition ~len:transition_count
          in
          let transition_indices =
            input_list
              ic
              ~f:(fun ic -> Option.value_exn (In_channel.input_byte ic))
              ~len:transition_count
          in
          let regimes = input_list ic ~f:input_regime ~len:type_count in
          let abbreviations = input_abbreviations ic ~len:abbrv_char_count in
          let leap_seconds = input_list ic ~f:input_leap_second ~len:leap_count in
          (* The following two arrays indicate two boolean values per regime that
             represent a three-value type that would translate to:

             type transition_type = UTC | Standard | Wall_clock

             However, these are only used by the system library when handling the case where the
             TZ variable is set, not to a time zone name, but instead is of the form:

             TZ = "std offset dst offset, rule"

             Which is deeply obscure, and almost certainly a mistake to use.  This library makes
             no pretense about handling this case.  We continue to read them in for
             completeness, and because it's possible that we will later discover a case where
             they are used. *)
          let _std_wall_indicators =
            input_array ic ~len:std_wall_count ~f:(fun ic ->
              bool_of_int (Option.value_exn (In_channel.input_byte ic)))
          in
          let _utc_local_indicators =
            input_array ic ~len:utc_local_count ~f:(fun ic ->
              bool_of_int (Option.value_exn (In_channel.input_byte ic)))
          in
          let regimes =
            Array.of_list
              (List.map regimes ~f:(fun (lt, abbrv_index) ->
                 let abbrv = Map.find_exn abbreviations abbrv_index in
                 lt abbrv))
          in
          let raw_transitions =
            List.map2_exn transition_times transition_indices ~f:(fun time index ->
              let regime = regimes.(index) in
              time, regime)
          in
          let transitions =
            let rec make_transitions acc l =
              match l with
              | [] -> Array.of_list (List.rev acc)
              | (start_time_in_seconds_since_epoch, new_regime) :: rest ->
                make_transitions
                  ({ Transition.start_time_in_seconds_since_epoch; new_regime } :: acc)
                  rest
            in
            make_transitions [] raw_transitions
          in
          let default_local_time_type =
            match Array.find regimes ~f:(fun r -> not r.Regime.is_dst) with
            | None -> regimes.(0)
            | Some ltt -> ltt
          in
          fun name ~original_filename ~digest ->
            { name
            ; original_filename = Some original_filename
            ; digest = Some digest
            ; transitions
            ; last_regime_index = Index.before_first_transition
            ; default_local_time_type
            ; leap_seconds
            }
        ;;

        let input_leap_second_gen ~input_leap_second ic =
          let time_in_seconds_since_epoch = input_leap_second ic in
          let seconds = input_long_as_int ic in
          { Leap_second.time_in_seconds_since_epoch; seconds }
        ;;

        let read_header ic =
          let magic =
            let buf = Bytes.create 4 in
            In_channel.really_input_exn ic ~buf ~pos:0 ~len:4;
            Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf
          in
          if not (String.equal magic "TZif")
          then raise (Invalid_file_format "magic characters TZif not present");
          let version =
            match In_channel.input_char ic with
            | Some '\000' -> `V1
            | Some '2' -> `V2
            | Some '3' -> `V3
            | None -> raise (Invalid_file_format "expected version, found nothing")
            | Some bad_version ->
              raise (Invalid_file_format (sprintf "version (%c) is invalid" bad_version))
          in
          (* space reserved for future use in the format *)
          In_channel.really_input_exn ic ~buf:(Bytes.create 15) ~pos:0 ~len:15;
          version
        ;;

        let input_tz_file_v1 ic =
          let input_leap_second =
            input_leap_second_gen ~input_leap_second:input_long_as_int63
          in
          input_tz_file_gen ~input_transition:input_long_as_int63 ~input_leap_second ic
        ;;

        (*
           version 2 timezone files have the format:

           part 1 - exactly the same as v1

           part 2 - same format as v1, except that 8 bytes are used to store
           transition times and leap seconds

           part 3 - a newline-encloded, POSIX-TZ-environment-variable-style
           string for use in handling instants after the last transition time
           stored in the file (with nothing between the newlines if there is no
           POSIX representation for such instants)

           We handle files in this format by parsing the first part exactly as a v1
           timezone file and then continuing to parse with 64bit reading functions in the
           right places.

           Version 3 timezone files are the same as version 2, except the
           POSIX-TZ-environment-variable-style string in part 3 may use two minor
           extensions to the POSIX TZ format (the hours part of its transition
           times may be signed and range from -167 through 167 instead of the
           POSIX-required unsigned values from 0 through 24; and DST is in effect all
           year if it starts January 1 at 00:00 and ends December 31 at 24:00 plus the
           difference between daylight saving and standard time).

           As we don't actually do anything with part 3 anyway, we can just read v3
           files as v2.
        *)
        let input_tz_file_v2_or_v3 ~version ic =
          let (_ : string -> original_filename:string -> digest:Md5_lib.t -> t) =
            input_tz_file_v1 ic
          in
          (* the header is fully repeated *)
          assert ([%compare.equal: [ `V1 | `V2 | `V3 ]] (read_header ic) version);
          let input_leap_second =
            input_leap_second_gen ~input_leap_second:input_long_long_as_int63
          in
          input_tz_file_gen
            ~input_transition:input_long_long_as_int63
            ~input_leap_second
            ic
        ;;

        let input_tz_file ~zonename ~filename =
          try
            protectx (In_channel.create filename) ~finally:In_channel.close ~f:(fun ic ->
              let make_zone =
                match read_header ic with
                | `V1 -> input_tz_file_v1 ic
                | (`V2 | `V3) as version -> input_tz_file_v2_or_v3 ~version ic
              in
              let digest = Md5.digest_file_blocking filename in
              let r = make_zone zonename ~original_filename:filename ~digest in
              r)
          with
          | Invalid_file_format reason ->
            raise (Invalid_file_format (sprintf "%s - %s" filename reason))
        ;;
      end

      let of_utc_offset_explicit_name ~name ~hours:offset =
        assert (offset >= -24 && offset <= 24);
        let utc_offset_in_seconds = Int63.of_int (offset * 60 * 60) in
        { name
        ; original_filename = None
        ; digest = None
        ; transitions = [||]
        ; last_regime_index = Index.before_first_transition
        ; default_local_time_type =
            { Regime.utc_offset_in_seconds; is_dst = false; abbrv = name }
        ; leap_seconds = []
        }
      ;;

      let of_utc_offset ~hours:offset =
        let name =
          if offset = 0
          then "UTC"
          else sprintf "UTC%s%d" (if offset < 0 then "-" else "+") (abs offset)
        in
        of_utc_offset_explicit_name ~name ~hours:offset
      ;;
    end
  end
end

include Stable.Full_data.V1

let sexp_of_t t = Sexp.Atom t.name

let likely_machine_zones =
  ref [ "America/New_York"; "Europe/London"; "Asia/Hong_Kong"; "America/Chicago" ]
;;

let input_tz_file = Zone_file.input_tz_file
let utc = of_utc_offset ~hours:0
let name zone = zone.name
let reset_transition_cache t = t.last_regime_index <- Index.before_first_transition

(* Raises if [index >= Array.length t.transitions] *)
let get_regime_exn t index =
  if index < 0 then t.default_local_time_type else t.transitions.(index).new_regime
;;

(* In "absolute mode", a number of seconds is interpreted as an offset of that many
   seconds from the UNIX epoch, ignoring leap seconds.

   In "date and ofday mode", you interpret the number of seconds as a number of days in
   combination with a number of seconds since midnight, which gives you a calendar day and
   a clock face time. Then you take the time that those represent in some relevant
   timezone.

   Of course, if the timezone in question has DST shifts, the date and ofday might
   represent two or zero times. These times will be interpreted according to either the
   previous UTC offset or the next one, in a way whose precise details you probably
   shouldn't depend on.

   (For the curious, what we do is: compute the "relative time" of the shift according to
   the new regime, and assign relative times to the old regime or new regime depending on
   which side of the shift time they occur. Since this amounts to using the old regime
   when the clocks move forward and the new regime when the clocks move back, it's
   equivalent to calculating the corresponding Time.t's relative to both the old and the
   new regime and picking the one that occurs later. Yes, later. I had to draw a diagram
   to persuade myself that it's that way round, but it is.)
*)
module Mode = struct
  type t =
    | Absolute
    | Date_and_ofday
end

let effective_start_time ~mode (x : Transition.t) =
  let open Int63.O in
  match (mode : Mode.t) with
  | Absolute -> x.start_time_in_seconds_since_epoch
  | Date_and_ofday ->
    x.start_time_in_seconds_since_epoch + x.new_regime.utc_offset_in_seconds
;;

let index_lower_bound_contains_seconds_since_epoch t index ~mode seconds =
  index < 0 || Int63.( >= ) seconds (effective_start_time ~mode t.transitions.(index))
;;

let index_upper_bound_contains_seconds_since_epoch t index ~mode seconds =
  index + 1 >= Array.length t.transitions
  || Int63.( < ) seconds (effective_start_time ~mode t.transitions.(index + 1))
;;

let binary_search_index_of_seconds_since_epoch t ~mode seconds : Index.t =
  Array.binary_search_segmented t.transitions `Last_on_left ~segment_of:(fun transition ->
    if Int63.( <= ) (effective_start_time transition ~mode) seconds
    then `Left
    else `Right)
  |> Option.value ~default:Index.before_first_transition
;;

let index_of_seconds_since_epoch t ~mode seconds =
  let index =
    let index = t.last_regime_index in
    if not (index_lower_bound_contains_seconds_since_epoch t index ~mode seconds)
    (* time is before cached index; try previous index *)
    then (
      let index = index - 1 in
      if not (index_lower_bound_contains_seconds_since_epoch t index ~mode seconds)
      (* time is before previous index; fall back on binary search *)
      then
        binary_search_index_of_seconds_since_epoch t ~mode seconds
        (* time is before cached index and not before previous, so within previous *)
      else index)
    else if not (index_upper_bound_contains_seconds_since_epoch t index ~mode seconds)
    (* time is after cached index; try next index *)
    then (
      let index = index + 1 in
      if not (index_upper_bound_contains_seconds_since_epoch t index ~mode seconds)
      (* time is after next index; fall back on binary search *)
      then
        binary_search_index_of_seconds_since_epoch t ~mode seconds
        (* time is after cached index and not after next, so within next *)
      else index (* time is within cached index *))
    else index
  in
  t.last_regime_index <- index;
  index
;;

module Time_in_seconds : sig
  include Zone_intf.Time_in_seconds
end = struct
  module Span = struct
    type t = Int63.t

    let of_int63_seconds = Fn.id
    let to_int63_seconds_round_down_exn = Fn.id
  end

  module Absolute = struct
    type t = Int63.t

    let of_span_since_epoch = Fn.id
    let to_span_since_epoch = Fn.id
  end

  module Date_and_ofday = struct
    type t = Int63.t

    let of_synthetic_span_since_epoch = Fn.id
    let to_synthetic_span_since_epoch = Fn.id
  end

  include Absolute
end

let index t time =
  Time_in_seconds.to_span_since_epoch time
  |> Time_in_seconds.Span.to_int63_seconds_round_down_exn
  |> index_of_seconds_since_epoch t ~mode:Absolute
;;

let index_of_date_and_ofday t time =
  Time_in_seconds.Date_and_ofday.to_synthetic_span_since_epoch time
  |> Time_in_seconds.Span.to_int63_seconds_round_down_exn
  |> index_of_seconds_since_epoch t ~mode:Date_and_ofday
;;

let index_has_prev_clock_shift t index = index >= 0 && index < Array.length t.transitions
let index_has_next_clock_shift t index = index_has_prev_clock_shift t (index + 1)

let index_prev_clock_shift_time_exn t index =
  let transition = t.transitions.(index) in
  transition.start_time_in_seconds_since_epoch
  |> Time_in_seconds.Span.of_int63_seconds
  |> Time_in_seconds.of_span_since_epoch
;;

let index_next_clock_shift_time_exn t index = index_prev_clock_shift_time_exn t (index + 1)

let index_prev_clock_shift_amount_exn t index =
  let transition = t.transitions.(index) in
  let after = transition.new_regime in
  let before =
    if index = 0 then t.default_local_time_type else t.transitions.(index - 1).new_regime
  in
  Int63.( - ) after.utc_offset_in_seconds before.utc_offset_in_seconds
  |> Time_in_seconds.Span.of_int63_seconds
;;

let index_next_clock_shift_amount_exn t index =
  index_prev_clock_shift_amount_exn t (index + 1)
;;

let index_abbreviation_exn t index =
  let regime = get_regime_exn t index in
  regime.abbrv
;;

let index_offset_from_utc_exn t index =
  let regime = get_regime_exn t index in
  Time_in_seconds.Span.of_int63_seconds regime.utc_offset_in_seconds
;;
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct