Implement FromField UTCTime

lib/Database/PostgreSQL/Opium/FromField.hs

@@ -20,6 +20,9 @@ import Data.Time
   ( Day (..)
   , DiffTime
   , TimeOfDay
+  , UTCTime (..)
+  , addDays
+  , fromGregorian
   , picosecondsToDiffTime
   , timeToTimeOfDay
   )
@@ -123,13 +126,16 @@ instance FromField Bool where
   validOid Proxy = Oid.boolean
   parseField = boolParser
 
+postgresEpoch :: Day
+postgresEpoch = fromGregorian 2000 1 1
+
 -- | See https://www.postgresql.org/docs/current/datatype-datetime.html.
 -- Relevant as well: https://git.postgresql.org/gitweb/?p=postgresql.git;a=blob;f=src/backend/utils/adt/datetime.c;h=267dfd37b2e8b9bc63797c69b9ca2e45e6bfde61;hb=HEAD#l267.
 instance FromField Day where
   validOid Proxy = Oid.date
-  parseField = fromJulianDay . fromIntegral <$> intParser @Int32
+  parseField = fromJulianDay <$> intParser @Int32
     where
-      fromJulianDay x = ModifiedJulianDay $ x + 51544
+      fromJulianDay x = addDays (fromIntegral x) postgresEpoch
 
 -- | See https://www.postgresql.org/docs/current/datatype-datetime.html.
 -- Binary format: https://git.postgresql.org/gitweb/?p=postgresql.git;a=blob;f=src/backend/utils/adt/date.c;h=ae0f24de2c3c54eb6d0405cdb212597c2407238e;hb=HEAD#l1542.
@@ -148,6 +154,19 @@ instance FromField TimeOfDay where
   validOid Proxy = Oid.time
   parseField = timeToTimeOfDay <$> parseField @DiffTime
 
+instance FromField UTCTime where
+  validOid Proxy = Oid.timestamp
+  parseField = fromPostgresTimestamp <$> intParser @Int
+    where
+      fromPostgresTimestamp :: Int -> UTCTime
+      fromPostgresTimestamp ts =
+        let
+          (days, microseconds) = ts `divMod` (86400 * 1000000)
+          day = addDays (fromIntegral days) postgresEpoch
+          time = picosecondsToDiffTime $ fromIntegral microseconds * 1000000
+        in
+          UTCTime day time
+
 newtype RawField a = RawField a
   deriving (Eq, Show)
 

lib/Database/PostgreSQL/Opium/Oid.hs

@@ -56,3 +56,7 @@ date = eq $ Oid 1082
 -- | Time of day.
 time :: Oid -> Bool
 time = eq $ Oid 1083
+
+-- | A point in time.
+timestamp :: Oid -> Bool
+timestamp = eq $ Oid 1114

test/Database/PostgreSQL/Opium/FromFieldSpec.hs

@@ -4,7 +4,15 @@
 module Database.PostgreSQL.Opium.FromFieldSpec (spec) where
 
 import Data.ByteString (ByteString)
-import Data.Time (Day (..), DiffTime, TimeOfDay (..), fromGregorian, secondsToDiffTime)
+import Data.Time
+  ( Day (..)
+  , DiffTime
+  , TimeOfDay (..)
+  , UTCTime (..)
+  , fromGregorian
+  , secondsToDiffTime
+  , timeOfDayToTime
+  )
 import Data.Text (Text)
 import Database.PostgreSQL.LibPQ (Connection)
 import Database.PostgreSQL.Opium (FromRow)
@@ -93,6 +101,12 @@ newtype ATimeOfDay = ATimeOfDay
 
 instance FromRow ATimeOfDay where
 
+newtype AUTCTime = AUTCTime
+  { utctime :: UTCTime
+  } deriving (Eq, Generic, Show)
+
+instance FromRow AUTCTime where
+
 newtype ARawField = ARawField
   { raw :: Opium.RawField ByteString
   } deriving (Eq, Generic, Show)
@@ -247,6 +261,22 @@ spec = do
       shouldFetch conn "SELECT time '00:01:00' AS timeofday" [ATimeOfDay $ TimeOfDay 0 1 0]
       shouldFetch conn "SELECT time '13:07:43' AS timeofday" [ATimeOfDay $ TimeOfDay 13 7 43]
 
+  describe "FromField UTCTime" $ do
+    it "Decodes timestamp" $ \conn -> do
+      let ts0 = UTCTime (fromGregorian 2023 10 2) (timeOfDayToTime $ TimeOfDay 12 42 23)
+      shouldFetch conn "SELECT timestamp '2023-10-02 12:42:23' AS utctime" [AUTCTime ts0]
+
+      let ts1 = UTCTime (fromGregorian 294275 12 31) (timeOfDayToTime $ TimeOfDay 23 59 59)
+      shouldFetch conn "SELECT timestamp '294275-12-31 23:59:59' AS utctime" [AUTCTime ts1]
+
+      let ts2 = UTCTime (fromGregorian 1 1 1) (timeOfDayToTime $ TimeOfDay 0 0 0)
+      shouldFetch conn "SELECT timestamp '0001-01-01 00:00:00' AS utctime" [AUTCTime ts2]
+
+      {- TODO: How does "BC" work here?
+      let ts3 = UTCTime (fromGregorian 0 1 1) (timeOfDayToTime $ TimeOfDay 0 0 0)
+      shouldFetch conn "SELECT timestamp 'January 1, 1 BC 00:00:00' AS utctime" [AUTCTime ts3]
+      -}
+
   describe "FromField RawField" $ do
     it "Simply returns the bytestring without decoding it" $ \conn -> do
       shouldFetch conn "SELECT 'Hello, World!'::bytea AS raw" [ARawField $ Opium.RawField "Hello, World!"]