Implement support for postgresql 'interval' type

Author: amarqueslee

postgresql-simple.cabal

@@ -82,7 +82,7 @@ library
  , containers >=0.5.0.0 && <0.7
  , template-haskell >=2.8.0.0 && <2.17
  , text >=1.2.3.0 && <1.3
- , time >=1.4.0.1 && <1.12
+ , time >=1.9.0.0 && <1.12
  , transformers >=0.3.0.0 && <0.6
 
  -- Other dependencies
@@ -150,6 +150,7 @@ test-suite test
  Notify
  Serializable
  Time
+ Interval
 
  ghc-options: -threaded
  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind

src/Database/PostgreSQL/Simple/FromField.hs

@@ -129,7 +129,7 @@ import Data.Functor.Identity (Identity(Identity))
 import Data.Int (Int16, Int32, Int64)
 import Data.IORef (IORef, newIORef)
 import Data.Ratio (Ratio)
-import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
 import Data.Typeable (Typeable, typeOf)
 import Data.Vector (Vector)
 import Data.Vector.Mutable (IOVector)
@@ -487,6 +487,15 @@ instance FromField LocalTimestamp where
 instance FromField Date where
  fromField = ff TI.dateOid "Date" parseDate
 
+-- | interval. Requires you to configure intervalstyle as @iso_8601@.
+--
+-- You can configure intervalstyle on every connection with a @SET@ command,
+-- but for better performance you may want to configure it permanently in the
+-- file found with @SHOW config_file;@ .
+--
+instance FromField CalendarDiffTime where
+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime
+
 ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
  -> Field -> Maybe B8.ByteString -> Conversion a
 ff compatOid hsType parseBS f mstr =

src/Database/PostgreSQL/Simple/Time.hs

@@ -227,6 +227,7 @@ module Database.PostgreSQL.Simple.Time
  , parseUTCTimestamp
  , parseZonedTimestamp
  , parseLocalTimestamp
+ , parseCalendarDiffTime
  , dayToBuilder
  , utcTimeToBuilder
  , zonedTimeToBuilder
@@ -239,6 +240,7 @@ module Database.PostgreSQL.Simple.Time
  , localTimestampToBuilder
  , unboundedToBuilder
  , nominalDiffTimeToBuilder
+ , calendarDiffTimeToBuilder
  ) where
 
 import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Implementation.hs

@@ -19,6 +19,7 @@ import Control.Arrow((***))
 import Control.Applicative
 import qualified Data.ByteString as B
 import Data.Time hiding (getTimeZone, getZonedTime)
+import Data.Time.LocalTime (CalendarDiffTime)
 import Data.Typeable
 import Data.Maybe (fromMaybe)
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -77,6 +78,9 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
 parseDate :: B.ByteString -> Either String Date
 parseDate = A.parseOnly (getDate <* A.endOfInput)
 
+parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
+
 getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
 getUnbounded getFinite
  = (pure NegInfinity <* A.string "-infinity")
@@ -125,6 +129,9 @@ getUTCTime = TP.utcTime
 getUTCTimestamp :: A.Parser UTCTimestamp
 getUTCTimestamp = getUnbounded getUTCTime
 
+getCalendarDiffTime :: A.Parser CalendarDiffTime
+getCalendarDiffTime = TP.calendarDiffTime
+
 dayToBuilder :: Day -> Builder
 dayToBuilder = primBounded TPP.day
 
@@ -164,3 +171,6 @@ dateToBuilder = unboundedToBuilder dayToBuilder
 
 nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
 nominalDiffTimeToBuilder = TPP.nominalDiffTime
+
+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
+calendarDiffTimeToBuilder = TPP.calendarDiffTime

src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs

@@ -21,18 +21,22 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser
  , localToUTCTimeOfDayHMS
  , utcTime
  , zonedTime
+ , calendarDiffTime
  ) where
 
 import Control.Applicative ((<$>), (<*>), (<*), (*>))
 import Database.PostgreSQL.Simple.Compat (toPico)
 import Data.Attoparsec.ByteString.Char8 as A
 import Data.Bits ((.&.))
+import Data.ByteString (ByteString)
 import Data.Char (ord)
 import Data.Fixed (Pico)
 import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
 import Data.Time.Calendar (Day, fromGregorianValid, addDays)
 import Data.Time.Clock (UTCTime(..))
+import Data.Time.Format.ISO8601 (iso8601ParseM)
+import Data.Time.LocalTime (CalendarDiffTime)
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Time.LocalTime as Local
 
@@ -193,3 +197,8 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
 
 utc :: Local.TimeZone
 utc = Local.TimeZone 0 False ""
+
+calendarDiffTime :: Parser CalendarDiffTime
+calendarDiffTime = do
+ contents <- takeByteString
+ iso8601ParseM $ B8.unpack contents

src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs

@@ -17,19 +17,23 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer
  , localTime
  , zonedTime
  , nominalDiffTime
+ , calendarDiffTime
  ) where
 
 import Control.Arrow ((>>>))
-import Data.ByteString.Builder (Builder, integerDec)
+import Data.ByteString.Builder (Builder, byteString, integerDec)
 import Data.ByteString.Builder.Prim
  ( liftFixedToBounded, (>$<), (>*<)
  , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
 import Data.Char ( chr )
 import Data.Int ( Int32, Int64 )
+import Data.String (fromString)
 import Data.Time
  ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
  , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
  , TimeZone, timeZoneMinutes )
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.Time.LocalTime (CalendarDiffTime)
 import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
 import Unsafe.Coerce (unsafeCoerce)
 
@@ -121,3 +125,11 @@ nominalDiffTime :: NominalDiffTime -> Builder
 nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
  where
  (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
+
+calendarDiffTime :: CalendarDiffTime -> Builder
+calendarDiffTime = byteString
+ . fromString
+ -- from the docs: "Beware: fromString truncates multi-byte characters to octets".
+ -- However, I think this is a safe usage, because ISO8601-encoding seems restricted
+ -- to ASCII output.
+ . iso8601Show

src/Database/PostgreSQL/Simple/ToField.hs

@@ -37,6 +37,7 @@ import Data.Int (Int8, Int16, Int32, Int64)
 import Data.List (intersperse)
 import Data.Monoid (mappend)
 import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
+import Data.Time.LocalTime (CalendarDiffTime)
 import Data.Typeable (Typeable)
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
@@ -293,6 +294,10 @@ instance ToField NominalDiffTime where
  toField = Plain . inQuotes . nominalDiffTimeToBuilder
  {-# INLINE toField #-}
 
+instance ToField CalendarDiffTime where
+ toField = Plain . inQuotes . calendarDiffTimeToBuilder
+ {-# INLINE toField #-}
+
 instance (ToField a) => ToField (PGArray a) where
  toField pgArray =
  case fromPGArray pgArray of

test/Interval.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{-
+
+Testing strategies:
+
+fromString . toString == id ** Todo?
+
+toString . fromString == almost id ** Todo?
+
+postgresql -> haskell -> postgresql * Done
+
+haskell -> postgresql -> haskell ** Todo?
+
+But still, what we really want to establish is that the two values
+correspond; for example, a conversion that consistently added hour
+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 Interval (testInterval) where
+
+import Common
+import Control.Monad(forM_, replicateM_)
+import Data.Time
+import Data.Time.LocalTime (CalendarDiffTime(..))
+import Data.Time.LocalTime (CalendarDiffTime(..))
+import Data.ByteString(ByteString)
+import Database.PostgreSQL.Simple.SqlQQ
+
+data IntervalTestCase = IntervalTestCase
+ { label :: String
+ , inputMonths :: Integer
+ , inputSeconds :: NominalDiffTime
+ , asText :: String
+ }
+ deriving (Eq, Show)
+
+testInterval :: TestEnv -> Assertion
+testInterval env@TestEnv{..} = do
+
+ initializeTable env
+
+ -- currently required for interval to work
+ execute_ conn "SET intervalstyle TO 'iso_8601'"
+
+ let milliseconds = 0.001
+ seconds = 1
+ minutes = 60 * seconds
+ hours = 60 * minutes
+ days = 24 * hours
+ weeks = 7 * days
+ months = 1
+ years = 12 * months
+
+ mapM (checkRoundTrip env)
+ [ IntervalTestCase
+ { label = "zero"
+ , inputMonths = 0
+ , inputSeconds = 0
+ , asText = "PT0"
+ }
+ , IntervalTestCase
+ { label = "1 year"
+ , inputMonths = 1 * years
+ , inputSeconds = 0
+ , asText = "P1Y"
+ }
+ , IntervalTestCase
+ { label = "2 months"
+ , inputMonths = 2 * months
+ , inputSeconds = 0
+ , asText = "P2M"
+ }
+ , IntervalTestCase
+ { label = "3 weeks"
+ , inputMonths = 0
+ , inputSeconds = 3 * weeks
+ , asText = "P3W"
+ }
+ , IntervalTestCase
+ { label = "4 days"
+ , inputMonths = 0
+ , inputSeconds = 4 * days
+ , asText = "P4D"
+ }
+ , IntervalTestCase
+ { label = "5 hours"
+ , inputMonths = 0
+ , inputSeconds = 5 * hours
+ , asText = "PT5H"
+ }
+ , IntervalTestCase
+ { label = "6 minutes"
+ , inputMonths = 0
+ , inputSeconds = 6 * minutes
+ , asText = "PT6M"
+ }
+ , IntervalTestCase
+ { label = "7 seconds"
+ , inputMonths = 0
+ , inputSeconds = 7 * seconds
+ , asText = "PT7S"
+ }
+ , IntervalTestCase
+ { label = "8 milliseconds"
+ , inputMonths = 0
+ , inputSeconds = 8 * milliseconds
+ , asText = "PT0.008S"
+ }
+ , IntervalTestCase
+ { label = "combination of intervals (day-size or bigger)"
+ , inputMonths = 2 * years + 4 * months
+ , inputSeconds = 3 * weeks + 5 * days
+ , asText = "P2Y4M3W5D"
+ }
+ , IntervalTestCase
+ { label = "combination of intervals (smaller than day-size)"
+ , inputMonths = 0
+ , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
+ , asText = "PT18H56M23.563S"
+ }
+ , IntervalTestCase
+ { label = "full combination of intervals"
+ , inputMonths = 2 * years + 4 * months
+ , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
+ , asText = "P2Y4M3W5DT18H56M23.563S"
+ }
+ ]
+
+ return ()
+
+initializeTable :: TestEnv -> IO ()
+initializeTable TestEnv{..} = withTransaction conn $ do
+ execute_ conn
+ [sql| CREATE TEMPORARY TABLE testinterval
+ ( id serial, sample interval, PRIMARY KEY(id) ) |]
+
+ return ()
+
+checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()
+checkRoundTrip TestEnv{..} IntervalTestCase{..} = do
+
+ let input = CalendarDiffTime
+ { ctMonths = inputMonths
+ , ctTime = inputSeconds
+ }
+
+ [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|
+ INSERT INTO testinterval (sample)
+ VALUES (?)
+ RETURNING id, sample
+ |] (Only input)
+
+ assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $
+ output == input
+
+ [(Only isExpectedIso)] <- query conn [sql|
+ SELECT sample = (?)::interval
+ FROM testinterval
+ WHERE id = ?
+ |] (asText, returnedId)
+
+ assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")
+ isExpectedIso
+

test/Main.hs

@@ -54,6 +54,7 @@ import Test.Tasty.Golden
 import Notify
 import Serializable
 import Time
+import Interval
 
 tests :: TestEnv -> TestTree
 tests env = testGroup "tests"
@@ -64,6 +65,7 @@ tests env = testGroup "tests"
  , testCase "Notify" . testNotify
  , testCase "Serializable" . testSerializable
  , testCase "Time" . testTime
+ , testCase "Interval" . testInterval
  , testCase "Array" . testArray
  , testCase "Array of nullables" . testNullableArray
  , testCase "HStore" . testHStore