5b3676c · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Implement support for postgresql 'interval' type

5b3676cAndre Marques Lee6 years ago

postgresql-simple.cabal+2−1

compare with master

unifiedsplit

@@ -82,7 +82,7 @@ library

82 , containers >=0.5.0.0 && <0.7

83 , template-haskell >=2.8.0.0 && <2.17

84 , text >=1.2.3.0 && <1.3

85− , time >=1.4.0.1 && <1.12

85+ , time >=1.9.0.0 && <1.12

86 , transformers >=0.3.0.0 && <0.6

88 -- Other dependencies

@@ -150,6 +150,7 @@ test-suite test

150 Notify

151 Serializable

152 Time

153+ Interval

153

154

154 ghc-options: -threaded

155 ghc-options: -threaded

155 ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind

156 ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind

src/Database/PostgreSQL/Simple/FromField.hs+10−1

@@ -129,7 +129,7 @@ import Data.Functor.Identity (Identity(Identity))

129import Data.Int (Int16, Int32, Int64)

130import Data.IORef (IORef, newIORef)

131import Data.Ratio (Ratio)

132−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

132+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )

133import Data.Typeable (Typeable, typeOf)

134import Data.Vector (Vector)

135import Data.Vector.Mutable (IOVector)

@@ -487,6 +487,15 @@ instance FromField LocalTimestamp where

487instance FromField Date where

488 fromField = ff TI.dateOid "Date" parseDate

489

490+-- | interval. Requires you to configure intervalstyle as @iso_8601@.

491+--

492+-- You can configure intervalstyle on every connection with a @SET@ command,

493+-- but for better performance you may want to configure it permanently in the

494+-- file found with @SHOW config_file;@ .

495+--

496+instance FromField CalendarDiffTime where

497+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime

498+

490ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)

499ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)

491 -> Field -> Maybe B8.ByteString -> Conversion a

500 -> Field -> Maybe B8.ByteString -> Conversion a

492ff compatOid hsType parseBS f mstr =

501ff compatOid hsType parseBS f mstr =

src/Database/PostgreSQL/Simple/Time.hs+2

@@ -227,6 +227,7 @@ module Database.PostgreSQL.Simple.Time

227 , parseUTCTimestamp

228 , parseZonedTimestamp

229 , parseLocalTimestamp

230+ , parseCalendarDiffTime

230 , dayToBuilder

231 , dayToBuilder

231 , utcTimeToBuilder

232 , utcTimeToBuilder

232 , zonedTimeToBuilder

233 , zonedTimeToBuilder

@@ -239,6 +240,7 @@ module Database.PostgreSQL.Simple.Time

239 , localTimestampToBuilder

240 , localTimestampToBuilder

240 , unboundedToBuilder

241 , unboundedToBuilder

241 , nominalDiffTimeToBuilder

242 , nominalDiffTimeToBuilder

243+ , calendarDiffTimeToBuilder

242 ) where

244 ) where

243

245

244import Database.PostgreSQL.Simple.Time.Implementation

246import Database.PostgreSQL.Simple.Time.Implementation

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

@@ -19,6 +19,7 @@ import Control.Arrow((***))

19import Control.Applicative

20import qualified Data.ByteString as B

21import Data.Time hiding (getTimeZone, getZonedTime)

22+import Data.Time.LocalTime (CalendarDiffTime)

22import Data.Typeable

23import Data.Typeable

23import Data.Maybe (fromMaybe)

24import Data.Maybe (fromMaybe)

24import qualified Data.Attoparsec.ByteString.Char8 as A

25import qualified Data.Attoparsec.ByteString.Char8 as A

@@ -77,6 +78,9 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)

77parseDate :: B.ByteString -> Either String Date

78parseDate :: B.ByteString -> Either String Date

78parseDate = A.parseOnly (getDate <* A.endOfInput)

79parseDate = A.parseOnly (getDate <* A.endOfInput)

81+parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime

82+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)

83+

80getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

84getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

81getUnbounded getFinite

85getUnbounded getFinite

82 = (pure NegInfinity <* A.string "-infinity")

86 = (pure NegInfinity <* A.string "-infinity")

@@ -125,6 +129,9 @@ getUTCTime = TP.utcTime

125getUTCTimestamp :: A.Parser UTCTimestamp

129getUTCTimestamp :: A.Parser UTCTimestamp

126getUTCTimestamp = getUnbounded getUTCTime

130getUTCTimestamp = getUnbounded getUTCTime

127

131

132+getCalendarDiffTime :: A.Parser CalendarDiffTime

133+getCalendarDiffTime = TP.calendarDiffTime

134+

128dayToBuilder :: Day -> Builder

135dayToBuilder :: Day -> Builder

129dayToBuilder = primBounded TPP.day

136dayToBuilder = primBounded TPP.day

130

137

@@ -164,3 +171,6 @@ dateToBuilder = unboundedToBuilder dayToBuilder

164

171

165nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

166nominalDiffTimeToBuilder = TPP.nominalDiffTime

173nominalDiffTimeToBuilder = TPP.nominalDiffTime

174+

175+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder

176+calendarDiffTimeToBuilder = TPP.calendarDiffTime

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

@@ -21,18 +21,22 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser

21 , localToUTCTimeOfDayHMS

22 , utcTime

23 , zonedTime

24+ , calendarDiffTime

24 ) where

25 ) where

26import Control.Applicative ((<$>), (<*>), (<*), (*>))

27import Control.Applicative ((<$>), (<*>), (<*), (*>))

27import Database.PostgreSQL.Simple.Compat (toPico)

28import Database.PostgreSQL.Simple.Compat (toPico)

28import Data.Attoparsec.ByteString.Char8 as A

29import Data.Attoparsec.ByteString.Char8 as A

29import Data.Bits ((.&.))

30import Data.Bits ((.&.))

31+import Data.ByteString (ByteString)

30import Data.Char (ord)

32import Data.Char (ord)

31import Data.Fixed (Pico)

33import Data.Fixed (Pico)

32import Data.Int (Int64)

34import Data.Int (Int64)

33import Data.Maybe (fromMaybe)

35import Data.Maybe (fromMaybe)

34import Data.Time.Calendar (Day, fromGregorianValid, addDays)

36import Data.Time.Calendar (Day, fromGregorianValid, addDays)

35import Data.Time.Clock (UTCTime(..))

37import Data.Time.Clock (UTCTime(..))

38+import Data.Time.Format.ISO8601 (iso8601ParseM)

39+import Data.Time.LocalTime (CalendarDiffTime)

36import qualified Data.ByteString.Char8 as B8

40import qualified Data.ByteString.Char8 as B8

37import qualified Data.Time.LocalTime as Local

41import qualified Data.Time.LocalTime as Local

@@ -193,3 +197,8 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

193

197

194utc :: Local.TimeZone

198utc :: Local.TimeZone

195utc = Local.TimeZone 0 False ""

199utc = Local.TimeZone 0 False ""

200+

201+calendarDiffTime :: Parser CalendarDiffTime

202+calendarDiffTime = do

203+ contents <- takeByteString

204+ iso8601ParseM $ B8.unpack contents

src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs+13−1

@@ -17,19 +17,23 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer

17 , localTime

18 , zonedTime

19 , nominalDiffTime

20+ , calendarDiffTime

20 ) where

21 ) where

22import Control.Arrow ((>>>))

23import Control.Arrow ((>>>))

23−import Data.ByteString.Builder (Builder, integerDec)

24+import Data.ByteString.Builder (Builder, byteString, integerDec)

24import Data.ByteString.Builder.Prim

25import Data.ByteString.Builder.Prim

25 ( liftFixedToBounded, (>$<), (>*<)

26 ( liftFixedToBounded, (>$<), (>*<)

26 , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)

27 , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)

27import Data.Char ( chr )

28import Data.Char ( chr )

28import Data.Int ( Int32, Int64 )

29import Data.Int ( Int32, Int64 )

30+import Data.String (fromString)

29import Data.Time

31import Data.Time

30 ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime

32 ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime

31 , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay

33 , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay

32 , TimeZone, timeZoneMinutes )

34 , TimeZone, timeZoneMinutes )

35+import Data.Time.Format.ISO8601 (iso8601Show)

36+import Data.Time.LocalTime (CalendarDiffTime)

33import Database.PostgreSQL.Simple.Compat ((<>), fromPico)

37import Database.PostgreSQL.Simple.Compat ((<>), fromPico)

34import Unsafe.Coerce (unsafeCoerce)

38import Unsafe.Coerce (unsafeCoerce)

@@ -121,3 +125,11 @@ nominalDiffTime :: NominalDiffTime -> Builder

121nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))

125nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))

122 where

126 where

123 (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000

127 (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000

128+

129+calendarDiffTime :: CalendarDiffTime -> Builder

130+calendarDiffTime = byteString

131+ . fromString

132+ -- from the docs: "Beware: fromString truncates multi-byte characters to octets".

133+ -- However, I think this is a safe usage, because ISO8601-encoding seems restricted

134+ -- to ASCII output.

135+ . iso8601Show

src/Database/PostgreSQL/Simple/ToField.hs+5

@@ -37,6 +37,7 @@ import Data.Int (Int8, Int16, Int32, Int64)

37import Data.List (intersperse)

38import Data.Monoid (mappend)

39import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

40+import Data.Time.LocalTime (CalendarDiffTime)

40import Data.Typeable (Typeable)

41import Data.Typeable (Typeable)

41import Data.Word (Word, Word8, Word16, Word32, Word64)

42import Data.Word (Word, Word8, Word16, Word32, Word64)

42import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

43import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

@@ -293,6 +294,10 @@ instance ToField NominalDiffTime where

293 toField = Plain . inQuotes . nominalDiffTimeToBuilder

294 toField = Plain . inQuotes . nominalDiffTimeToBuilder

294 {-# INLINE toField #-}

295 {-# INLINE toField #-}

295

296

297+instance ToField CalendarDiffTime where

298+ toField = Plain . inQuotes . calendarDiffTimeToBuilder

299+ {-# INLINE toField #-}

300+

296instance (ToField a) => ToField (PGArray a) where

301instance (ToField a) => ToField (PGArray a) where

297 toField pgArray =

302 toField pgArray =

298 case fromPGArray pgArray of

303 case fromPGArray pgArray of

test/Interval.hsnew file+180

@@ -0,0 +1,180 @@

1+{-# LANGUAGE QuasiQuotes #-}

3+{-

5+Testing strategies:

7+fromString . toString == id ** Todo?

9+toString . fromString == almost id ** Todo?

10+

11+postgresql -> haskell -> postgresql * Done

12+

13+haskell -> postgresql -> haskell ** Todo?

14+

15+But still, what we really want to establish is that the two values

16+correspond; for example, a conversion that consistently added hour

17+when printed to a string and subtracted an hour when parsed from string

18+would still pass these tests.

19+

20+

21+Right now, we are checking that 1400+ timestamps in the range of 1860 to

22+2060 round trip from postgresql to haskell and back in 5 different timezones.

23+In addition to UTC, the four timezones were selected so that 2 have a positive

24+offset, and 2 have a negative offset, and that 2 have an offset of a

25+whole number of hours, while the other two do not.

26+

27+It may be worth adding a few more timezones to ensure better test coverage.

28+

29+We are checking a handful of selected timestamps to ensure we hit

30+various corner-cases in the code, in addition to 1400 timestamps randomly

31+generated with granularity of seconds down to microseconds in powers of ten.

32+

33+-}

34+

35+module Interval (testInterval) where

36+

37+import Common

38+import Control.Monad(forM_, replicateM_)

39+import Data.Time

40+import Data.Time.LocalTime (CalendarDiffTime(..))

41+import Data.Time.LocalTime (CalendarDiffTime(..))

42+import Data.ByteString(ByteString)

43+import Database.PostgreSQL.Simple.SqlQQ

44+

45+data IntervalTestCase = IntervalTestCase

46+ { label :: String

47+ , inputMonths :: Integer

48+ , inputSeconds :: NominalDiffTime

49+ , asText :: String

50+ }

51+ deriving (Eq, Show)

52+

53+testInterval :: TestEnv -> Assertion

54+testInterval env@TestEnv{..} = do

55+

56+ initializeTable env

57+

58+ -- currently required for interval to work

59+ execute_ conn "SET intervalstyle TO 'iso_8601'"

60+

61+ let milliseconds = 0.001

62+ seconds = 1

63+ minutes = 60 * seconds

64+ hours = 60 * minutes

65+ days = 24 * hours

66+ weeks = 7 * days

67+ months = 1

68+ years = 12 * months

69+

70+ mapM (checkRoundTrip env)

71+ [ IntervalTestCase

72+ { label = "zero"

73+ , inputMonths = 0

74+ , inputSeconds = 0

75+ , asText = "PT0"

76+ }

77+ , IntervalTestCase

78+ { label = "1 year"

79+ , inputMonths = 1 * years

80+ , inputSeconds = 0

81+ , asText = "P1Y"

82+ }

83+ , IntervalTestCase

84+ { label = "2 months"

85+ , inputMonths = 2 * months

86+ , inputSeconds = 0

87+ , asText = "P2M"

88+ }

89+ , IntervalTestCase

90+ { label = "3 weeks"

91+ , inputMonths = 0

92+ , inputSeconds = 3 * weeks

93+ , asText = "P3W"

94+ }

95+ , IntervalTestCase

96+ { label = "4 days"

97+ , inputMonths = 0

98+ , inputSeconds = 4 * days

99+ , asText = "P4D"

100+ }

101+ , IntervalTestCase

102+ { label = "5 hours"

103+ , inputMonths = 0

104+ , inputSeconds = 5 * hours

105+ , asText = "PT5H"

106+ }

107+ , IntervalTestCase

108+ { label = "6 minutes"

109+ , inputMonths = 0

110+ , inputSeconds = 6 * minutes

111+ , asText = "PT6M"

112+ }

113+ , IntervalTestCase

114+ { label = "7 seconds"

115+ , inputMonths = 0

116+ , inputSeconds = 7 * seconds

117+ , asText = "PT7S"

118+ }

119+ , IntervalTestCase

120+ { label = "8 milliseconds"

121+ , inputMonths = 0

122+ , inputSeconds = 8 * milliseconds

123+ , asText = "PT0.008S"

124+ }

125+ , IntervalTestCase

126+ { label = "combination of intervals (day-size or bigger)"

127+ , inputMonths = 2 * years + 4 * months

128+ , inputSeconds = 3 * weeks + 5 * days

129+ , asText = "P2Y4M3W5D"

130+ }

131+ , IntervalTestCase

132+ { label = "combination of intervals (smaller than day-size)"

133+ , inputMonths = 0

134+ , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds

135+ , asText = "PT18H56M23.563S"

136+ }

137+ , IntervalTestCase

138+ { label = "full combination of intervals"

139+ , inputMonths = 2 * years + 4 * months

140+ , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds

141+ , asText = "P2Y4M3W5DT18H56M23.563S"

142+ }

143+ ]

144+

145+ return ()

146+

147+initializeTable :: TestEnv -> IO ()

148+initializeTable TestEnv{..} = withTransaction conn $ do

149+ execute_ conn

150+ [sql| CREATE TEMPORARY TABLE testinterval

151+ ( id serial, sample interval, PRIMARY KEY(id) ) |]

152+

153+ return ()

154+

155+checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()

156+checkRoundTrip TestEnv{..} IntervalTestCase{..} = do

157+

158+ let input = CalendarDiffTime

159+ { ctMonths = inputMonths

160+ , ctTime = inputSeconds

161+ }

162+

163+ [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|

164+ INSERT INTO testinterval (sample)

165+ VALUES (?)

166+ RETURNING id, sample

167+ |] (Only input)

168+

169+ assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $

170+ output == input

171+

172+ [(Only isExpectedIso)] <- query conn [sql|

173+ SELECT sample = (?)::interval

174+ FROM testinterval

175+ WHERE id = ?

176+ |] (asText, returnedId)

177+

178+ assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")

179+ isExpectedIso

180+

test/Main.hs+2

@@ -54,6 +54,7 @@ import Test.Tasty.Golden

54import Notify

55import Serializable

56import Time

57+import Interval

58tests :: TestEnv -> TestTree

59tests :: TestEnv -> TestTree

59tests env = testGroup "tests"

60tests env = testGroup "tests"

@@ -64,6 +65,7 @@ tests env = testGroup "tests"

64 , testCase "Notify" . testNotify

65 , testCase "Notify" . testNotify

65 , testCase "Serializable" . testSerializable

66 , testCase "Serializable" . testSerializable

66 , testCase "Time" . testTime

67 , testCase "Time" . testTime

68+ , testCase "Interval" . testInterval

67 , testCase "Array" . testArray

69 , testCase "Array" . testArray

68 , testCase "Array of nullables" . testNullableArray

70 , testCase "Array of nullables" . testNullableArray

69 , testCase "HStore" . testHStore

71 , testCase "HStore" . testHStore