diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.4.6.0 +Version: 0.4.7.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -81,7 +81,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.4.6.0 + tag: v0.4.7.0 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs --- a/src/Database/PostgreSQL/Simple/Time/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -98,7 +98,7 @@ let !year = toNum yearStr _ <- A.char '-' - month <- digits "month" + !month <- digits "month" _ <- A.char '-' day <- digits "day" @@ -115,7 +115,7 @@ getTimeOfDay :: A.Parser TimeOfDay getTimeOfDay = do - hour <- digits "hours" + !hour <- digits "hours" _ <- A.char ':' minute <- digits "minutes" _ <- A.char ':' @@ -136,13 +136,43 @@ getTimeZone :: A.Parser TimeZone getTimeZone = do - sign <- A.satisfy (\c -> c == '+' || c == '-') - hours <- digits "timezone" - mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 + !sign <- A.satisfy (\c -> c == '+' || c == '-') + !hours <- digits "timezone" + !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 let !absset = 60 * hours + mins !offset = if sign == '+' then absset else -absset return $! minutesToTimeZone offset +type TimeZoneHMS = (Int,Int,Int) + +getTimeZoneHMS :: A.Parser TimeZoneHMS +getTimeZoneHMS = do + !sign <- A.satisfy (\c -> c == '+' || c == '-') + !hours <- digits "timezone" + !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 + !secs <- (A.char ':' *> digits "timezone seconds") <|> pure 0 + if sign == '+' + then return $! (hours, mins, secs) + else return $! (\ !h !m !s -> (h,m,s)) (-hours) (-mins) (-secs) + +localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) +localToUTCTimeOfDayHMS (dh, dm, ds) (TimeOfDay h m s) = + (\ !a !b -> (a,b)) dday (TimeOfDay h'' m'' s'') + where + s' = s - fromIntegral ds + (!s'', m') + | s' < 0 = (s' + 60, m - dm - 1) + | s' >= 60 = (s' - 60, m - dm + 1) + | otherwise = (s' , m - dm ) + (!m'', h') + | m' < 0 = (m' + 60, h - dh - 1) + | m' >= 60 = (m' - 60, h - dh + 1) + | otherwise = (m' , h - dh ) + (!h'', dday) + | h' < 0 = (h' + 24, -1) + | h' >= 24 = (h' - 24, 1) + | otherwise = (h' , 0) + getZonedTime :: A.Parser ZonedTime getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone @@ -154,11 +184,11 @@ day <- getDay _ <- A.char ' ' time <- getTimeOfDay - zone <- getTimeZone - let (!dayDelta,!time') = localToUTCTimeOfDay zone time + zone <- getTimeZoneHMS + let !(dayDelta,time') = localToUTCTimeOfDayHMS zone time let !day' = addDays dayDelta day let !time'' = timeOfDayToTime time' - return (UTCTime day' time'') + return $! UTCTime day' time'' getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime diff --git a/src/Database/PostgreSQL/Simple/Time/Internal.hs b/src/Database/PostgreSQL/Simple/Time/Internal.hs --- a/src/Database/PostgreSQL/Simple/Time/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Time/Internal.hs @@ -19,6 +19,9 @@ , getZonedTimestamp , getUTCTime , getUTCTimestamp + , TimeZoneHMS + , getTimeZoneHMS + , localToUTCTimeOfDayHMS ) where import Database.PostgreSQL.Simple.Time.Implementation diff --git a/test/Time.hs b/test/Time.hs --- a/test/Time.hs +++ b/test/Time.hs @@ -17,6 +17,19 @@ when printed to a string and subtracted an hour when parsed from string would still pass these tests. + +Right now, we are checking that 1400+ timestamps in the range of 1860 to +2060 round trip from postgresql to haskell and back in 5 different timezones. +In addition to UTC, the four timezones were selected so that 2 have a positive +offset, and 2 have a negative offset, and that 2 have an offset of a +whole number of hours, while the other two do not. + +It may be worth adding a few more timezones to ensure better test coverage. + +We are checking a handful of selected timestamps to ensure we hit +various corner-cases in the code, in addition to 1400 timestamps randomly +generated with granularity of seconds down to microseconds in powers of ten. + -} module Time (testTime) where @@ -35,13 +48,13 @@ initializeTable env execute_ conn "SET timezone TO 'UTC'" checkRoundTrips env - execute_ conn "SET timezone TO 'America/Chicago'" + execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00 checkRoundTrips env - execute_ conn "SET timezone TO 'Asia/Tokyo'" + execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00 checkRoundTrips env - execute_ conn "SET timezone TO 'Asia/Kathmandu'" + execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45 checkRoundTrips env - execute_ conn "SET timezone TO 'America/St_Johns'" + execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30 checkRoundTrips env initializeTable :: TestEnv -> IO () @@ -49,10 +62,37 @@ execute_ conn [sql| CREATE TEMPORARY TABLE testtime ( x serial, y timestamptz, PRIMARY KEY(x) ) |] + + let test :: ByteString -> IO () = \x -> do + execute conn [sql| + INSERT INTO testtime (y) VALUES (?) + |] (Only x) + return () + -- America/Chicago + test "1883-11-18 11:59:59-05:50:36" + test "1883-11-18 12:09:23-05:50:36" + test "1883-11-18 12:00:00-06" + -- Asia/Tokyo + test "1887-12-31 23:59:59+09:18:59" + test "1888-01-01 00:18:58+09:18:59" + test "1888-01-01 00:00:00+09" + -- Asia/Kathmandu + test "1919-12-31 23:59:59+05:41:16" + test "1919-12-31 23:48:44+05:30" + test "1985-12-31 23:59:59+05:30" + test "1986-01-01 00:15:00+05:45" + -- America/St_Johns + test "1935-03-29 23:59:59-03:30:52" + test "1935-03-30 00:00:52-03:30" + + -- While the above special cases are probably a decent start, there + -- are probably more that are well worth adding to ensure better + -- coverage. + let pop :: ByteString -> Double -> IO () = \x y -> replicateM_ numTests $ execute conn [sql| INSERT INTO testtime (y) VALUES - ('1936-01-01 00:00:00+00'::timestamptz + ('1860-01-01 00:00:00+00'::timestamptz + ?::interval * ROUND(RANDOM() * ?)) |] (x,y) pop "1 microsecond" 6.3113904e15 pop "10 microseconds" 6.3113904e14