From 265516aa5702f01f2f875525f3a9aae59bc2afe9 Mon Sep 17 00:00:00 2001 From: Joe Thomas Date: Mon, 21 Jun 2021 09:22:28 -0600 Subject: [PATCH] Add Pgx_value_ptime with ptime converters (#114) This change addresses issue #97 by introducing a new package called Pgx_value_ptime. This package is analogous to Pgx_value_core, but uses Ptime for date/date-time processing instead of Core. The tests for Pgx_value_ptime are pretty much the same as those for Pgx_value_core, although I did add some extra tests for dates. --- dune-project | 16 +++ pgx_value_ptime.opam | 32 +++++ pgx_value_ptime/src/dune | 15 +++ pgx_value_ptime/src/pgx_value_ptime.ml | 58 +++++++++ pgx_value_ptime/src/pgx_value_ptime.mli | 17 +++ pgx_value_ptime/test/dune | 4 + pgx_value_ptime/test/test_pgx_value_ptime.ml | 123 +++++++++++++++++++ 7 files changed, 265 insertions(+) create mode 100644 pgx_value_ptime.opam create mode 100644 pgx_value_ptime/src/dune create mode 100644 pgx_value_ptime/src/pgx_value_ptime.ml create mode 100644 pgx_value_ptime/src/pgx_value_ptime.mli create mode 100644 pgx_value_ptime/test/dune create mode 100644 pgx_value_ptime/test/test_pgx_value_ptime.ml diff --git a/dune-project b/dune-project index 1782c61..21fed8b 100644 --- a/dune-project +++ b/dune-project @@ -145,6 +145,22 @@ (pgx (= :version)))) +(package + (name pgx_value_ptime) + (synopsis "Pgx_value converters for Ptime types") + (description "Pgx_value converters for Ptime types") + (depends + (alcotest + (and + :with-test + (>= 1.0.0))) + (ptime + (>= 0.8.3)) + (ocaml + (>= 4.08)) + (pgx + (= :version)))) + (package (name pgx_lwt_mirage) (synopsis "Pgx using Lwt on Mirage for IO") diff --git a/pgx_value_ptime.opam b/pgx_value_ptime.opam new file mode 100644 index 0000000..6e8dd5d --- /dev/null +++ b/pgx_value_ptime.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Pgx_value converters for Ptime types" +description: "Pgx_value converters for Ptime types" +maintainer: ["Arena Developers "] +authors: ["Arena Developers "] +license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" +homepage: "https://github.com/arenadotio/pgx" +doc: "https://arenadotio.github.io/pgx" +bug-reports: "https://github.com/arenadotio/pgx/issues" +depends: [ + "dune" {>= "1.11"} + "alcotest" {with-test & >= "1.0.0"} + "ptime" {>= "0.8.3"} + "ocaml" {>= "4.08"} + "pgx" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/arenadotio/pgx.git" diff --git a/pgx_value_ptime/src/dune b/pgx_value_ptime/src/dune new file mode 100644 index 0000000..8f758f7 --- /dev/null +++ b/pgx_value_ptime/src/dune @@ -0,0 +1,15 @@ +(* -*- tuareg -*- *) + +let preprocess = + match Sys.getenv "BISECT_ENABLE" with + | "yes" -> "(preprocess (pps bisect_ppx))" + | _ -> "" + | exception Not_found -> "" + +let () = Jbuild_plugin.V1.send @@ {| + +(library + (public_name pgx_value_ptime) + (libraries ptime pgx) + |} ^ preprocess ^ {|) +|} diff --git a/pgx_value_ptime/src/pgx_value_ptime.ml b/pgx_value_ptime/src/pgx_value_ptime.ml new file mode 100644 index 0000000..99d43c6 --- /dev/null +++ b/pgx_value_ptime/src/pgx_value_ptime.ml @@ -0,0 +1,58 @@ +include Pgx.Value + +let of_date (year, month, day) = + Printf.sprintf "%04d-%02d-%02d" year month day |> Pgx.Value.of_string +;; + +let to_date' text = + match text ^ "T00:00:00Z" |> Ptime.of_rfc3339 with + | Result.Ok (t, _, _) -> Ptime.to_date t + | _ -> convert_failure "date" text +;; + +let to_date_exn v = Pgx.Value.to_string_exn v |> to_date' +let to_date v = Pgx.Value.to_string v |> Option.map to_date' + +let of_time ?tz_offset_s t = + let tz_offset_s = Option.value tz_offset_s ~default:0 in + Ptime.to_rfc3339 ~tz_offset_s ~frac_s:12 t |> Pgx.Value.of_string +;; + +let time_of_string text = + match Ptime.of_rfc3339 text with + | Result.Ok (t, offset, _) -> t, Option.value ~default:0 offset + | _ -> convert_failure "time" text +;; + +let to_time' text = + (* + The time string can come in various forms depending on whether the + Postgres timestamp used includes the time zone: + + Without timezone + 2016-06-07 15:37:46 + 2016-06-07 15:37:46.962425 + + With timezone + 2016-06-07 15:37:46-04 + 2016-06-07 15:37:46.962425-04 + + For the first one we need to indicate that it's a UTC time by appending + a 'Z'. For the second one we need to append the minutes to the timezone. + *) + let open Re in + let tz = seq [ alt [ char '-'; char '+' ]; digit; digit ] in + let utctz = seq [ char 'Z'; eol ] |> compile in + let localtz = seq [ tz; char ':'; digit; digit; eol ] |> compile in + let localtz_no_min = seq [ tz; eol ] |> compile in + time_of_string + @@ + match matches utctz text, matches localtz text, matches localtz_no_min text with + | [], [], [] -> text ^ "Z" + | _, _, [] -> text + | [], [], _ -> text ^ ":00" + | _ -> convert_failure "time" text +;; + +let to_time_exn v = Pgx.Value.to_string_exn v |> to_time' +let to_time v = Pgx.Value.to_string v |> Option.map to_time' diff --git a/pgx_value_ptime/src/pgx_value_ptime.mli b/pgx_value_ptime/src/pgx_value_ptime.mli new file mode 100644 index 0000000..2202967 --- /dev/null +++ b/pgx_value_ptime/src/pgx_value_ptime.mli @@ -0,0 +1,17 @@ +(** Pgx_value types using Ptime's Date and Time modules + +To use Ptime in utop, first run: #require "ptime";; +*) + +type v = Pgx.Value.v [@@deriving compare, sexp_of] +type t = Pgx.Value.t [@@deriving compare, sexp_of] + +include module type of Pgx.Value with type v := v and type t := t + +val of_date : Ptime.date -> t +val to_date_exn : t -> Ptime.date +val to_date : t -> Ptime.date option +val of_time : ?tz_offset_s:Ptime.tz_offset_s -> Ptime.t -> t +val to_time_exn : t -> Ptime.t * Ptime.tz_offset_s +val to_time : t -> (Ptime.t * Ptime.tz_offset_s) option +val time_of_string : string -> Ptime.t * Ptime.tz_offset_s diff --git a/pgx_value_ptime/test/dune b/pgx_value_ptime/test/dune new file mode 100644 index 0000000..d6038c0 --- /dev/null +++ b/pgx_value_ptime/test/dune @@ -0,0 +1,4 @@ +(tests + (names test_pgx_value_ptime) + (package pgx_value_ptime) + (libraries alcotest pgx_value_ptime)) diff --git a/pgx_value_ptime/test/test_pgx_value_ptime.ml b/pgx_value_ptime/test/test_pgx_value_ptime.ml new file mode 100644 index 0000000..763e44e --- /dev/null +++ b/pgx_value_ptime/test/test_pgx_value_ptime.ml @@ -0,0 +1,123 @@ +module Value = Pgx_value_ptime + +(* Show both an human-readable version of the date and the underlying + seconds/offset pair for the input datetime.*) +let print_time (t, tz_offset_s) = + let sec = Ptime.to_float_s t + and txt = Ptime.to_rfc3339 t ~tz_offset_s ~frac_s:6 in + Printf.sprintf "<%s | Seconds: %f, Offset: %d>" txt sec tz_offset_s +;; + +let value_testable = + let print_time value = + match Pgx.Value.to_string value with + | Some text -> text + | None -> "" + in + let formatter ppf value = Format.pp_print_string ppf (print_time value) in + Alcotest.testable formatter ( = ) +;; + +let check_value = Alcotest.check value_testable + +let test_to_date _ = + let check_date = Alcotest.(check (triple int int int)) in + let value = Pgx.Value.of_string "2021-11-14" in + let expected = 2021, 11, 14 in + check_date "check date parsing" expected (Value.to_date_exn value); + let value = Pgx.Value.of_string "0900-06-13" in + let expected = 900, 6, 13 in + check_date "check date with leading zeros" expected (Value.to_date_exn value) +;; + +let test_of_date _ = + let date = 2021, 11, 14 in + let expected = Pgx.Value.of_string "2021-11-14" in + check_value "check date rendering" expected (Value.of_date date); + let date = 900, 6, 13 in + let expected = Pgx.Value.of_string "0900-06-13" in + check_value "dates with leading zeros render properly" expected (Value.of_date date) +;; + +let date_tests = + [ Alcotest.test_case "of_date renders a Ptime date to a Pgx Value" `Quick test_of_date + ; Alcotest.test_case "to_date parses a Pgx Value to a Ptime date" `Quick test_to_date + ] +;; + +(* Show only the human-readable version of the date-time. *) +let check_time = + let compare_times (t1, o1) (t2, o2) = + let tf1 = Ptime.to_float_s t1 + and tf2 = Ptime.to_float_s t2 in + abs_float (tf1 -. tf2) < 1.0e-6 && o1 = o2 + in + let time_testable = + Alcotest.testable + (fun ppf t -> Format.pp_print_string ppf (print_time t)) + compare_times + in + Alcotest.check time_testable +;; + +let test_time_of_string _ = + let hour = 3600 in + let hourf = 3600. in + let to_pt x = Ptime.of_float_s x |> Option.value ~default:Ptime.min in + check_time + "minimum time parses" + (Ptime.min, 0) + (Value.time_of_string "0000-01-01T00:00:00Z"); + let pt = to_pt (12. *. hourf) in + check_time + "time with tz offset parses" + (pt, ~-4 * hour) + (Value.time_of_string "1970-01-01T08:00:00-04:00"); + let pt = to_pt ((12. *. hourf) +. 0.12345) in + check_time + "a time with milliseconds parses" + (pt, 0) + (Value.time_of_string "1970-01-01T12:00:00.12345Z"); + (* On linux, one can run "TZ='UTC' date -d @1458086118" in a shell to confirm this conversion is correct.*) + check_time + "a recent time parses" + (to_pt 1458086118., ~-4 * hour) + (Value.time_of_string "2016-03-15 19:55:18-04:00") +;; + +let time_roundtrip str = Value.of_string str |> Value.to_time_exn + +let test_time_tz_handling _ = + let utc_t, tz_offset_s = Value.time_of_string "2016-03-15 19:55:18-04:00" in + check_time "without TZ" (utc_t, 0) (time_roundtrip "2016-03-15 23:55:18"); + check_time "zulu" (utc_t, 0) (time_roundtrip "2016-03-15 23:55:18Z"); + check_time "hour TZ" (utc_t, tz_offset_s) (time_roundtrip "2016-03-15 19:55:18-04"); + check_time "full TZ" (utc_t, tz_offset_s) (time_roundtrip "2016-03-15 19:55:18-04:00") +;; + +let test_time_conversion_roundtrip _ = + let print_time (t, tz_offset_s) = Ptime.to_rfc3339 t ~tz_offset_s ~frac_s:6 in + let expected_str = "2016-03-15T23:55:18.123456Z" in + Alcotest.(check string) + "parse-print" + expected_str + (time_roundtrip expected_str |> print_time); + let t, tz_offset_s = Value.time_of_string expected_str in + let actual = Value.of_time t ~tz_offset_s |> Value.to_time_exn in + check_time "print-parse" (t, tz_offset_s) actual +;; + +let time_tests = + [ Alcotest.test_case "test time_of_string" `Quick test_time_of_string + ; Alcotest.test_case + "test time_of_string time zone handling" + `Quick + test_time_tz_handling + ; Alcotest.test_case + "test time conversion roundtrip" + `Quick + test_time_conversion_roundtrip + ] +;; + +let () = Alcotest.run "pgx_async_conversions" [ "date", date_tests; "time", time_tests ]