Implement support for postgresql 'interval' type

appveyor.yml

@@ -9,7 +9,7 @@ services:
 
 environment:
   global:
-    CABOPTS:  "--store-dir=C:\\SR --http-transport=plain-http"
+    CABOPTS:  "--minimize-conflict-set --store-dir=C:\\SR --http-transport=plain-http"
     PGUSER: postgres
     PGPASSWORD: Password12!
     PGPORT: "5432"

postgresql-simple.cabal

@@ -77,12 +77,12 @@ library
 
   -- GHC bundled libs
   build-depends:
-      base              >=4.6.0.0  && <4.15
+      base              >=4.7.0.0  && <4.15
     , bytestring        >=0.10.0.0 && <0.12
     , 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"
+      }
+    ]
+
+  pure ()
+
+initializeTable :: TestEnv -> IO ()
+initializeTable TestEnv{..} = withTransaction conn $ do
+  execute_ conn
+     [sql| CREATE TEMPORARY TABLE testinterval
+             ( id serial, sample interval, PRIMARY KEY(id) ) |]
+
+  pure ()
+
+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

@@ -53,6 +53,7 @@ import Test.Tasty.Golden
 import Notify
 import Serializable
 import Time
+import Interval
 
 tests :: TestEnv -> TestTree
 tests env = testGroup "tests"
@@ -63,6 +64,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