postgresql-binary 0.2.3 → 0.3.0
raw patch · 11 files changed
+240/−157 lines, 11 filesdep +transformersdep ~bytestring
Dependencies added: transformers
Dependency ranges changed: bytestring
Files
- executables/Decoding.hs +3/−3
- executables/Encoding.hs +20/−20
- executables/Tests.hs +69/−31
- library/PostgreSQLBinary/Decoder.hs +21/−27
- library/PostgreSQLBinary/Encoder.hs +8/−4
- library/PostgreSQLBinary/Encoder/Builder.hs +4/−18
- library/PostgreSQLBinary/Interval.hs +1/−1
- library/PostgreSQLBinary/Numeric.hs +5/−5
- library/PostgreSQLBinary/Prelude.hs +4/−2
- library/PostgreSQLBinary/Time.hs +100/−44
- postgresql-binary.cabal +5/−2
executables/Decoding.hs view
@@ -30,9 +30,9 @@ b "date" D.date (E.date (read "2000-01-19")), b "time" (D.time True) (E.time True (read "10:41:06")), b "timetz" (D.timetz True) (E.timetz True (read "(10:41:06, +0300)")),- b "timestamp" D.timestamp (E.timestamp (read "2000-01-19 10:41:06")),- b "timestamptz" D.timestamptz (E.timestamptz (read "2000-01-19 10:41:06")),- b "interval" D.interval (E.interval (secondsToDiffTime 23472391470128374)),+ b "timestamp" (D.timestamp True) (E.timestamp True (read "2000-01-19 10:41:06")),+ b "timestamptz" (D.timestamptz True) (E.timestamptz True (read "2000-01-19 10:41:06")),+ b "interval" D.interval (E.interval (secondsToDiffTime 23472391128374)), b "uuid" D.uuid (E.uuid (read "550e8400-e29b-41d4-a716-446655440000")), b "array" D.array (E.array (Array.fromListUnsafe
executables/Encoding.hs view
@@ -17,26 +17,26 @@ main = defaultMain [- b "bool" E.bool True,- b "int2" E.int2 (Left 1000),- b "int4" E.int4 (Left 1000),- b "int8" E.int8 (Left 1000),- b "float4" E.float4 12.65468468,- b "float8" E.float8 12.65468468,- b "numeric" E.numeric (read "20.213290183"),- b "char" E.char 'Я',- b "text" E.text (Left "alsdjflskjдывлоаы оады"),- b "bytea" E.bytea (Left "alskdfj;dasjfl;dasjflksdj"),- b "date" E.date (read "2000-01-19"),- b "time" (E.time True) (read "10:41:06"),- b "timetz" (E.timetz True) (read "(10:41:06, +0300)"),- b "timestamp" E.timestamp (read "2000-01-19 10:41:06"),- b "timestamptz" E.timestamptz (read "2000-01-19 10:41:06"),- b "interval" E.interval (secondsToDiffTime 23472391470128374),- b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"),- b "array" E.array (Array.fromListUnsafe - [Array.fromSingleton (Just "dfs") True 0,- Array.fromSingleton Nothing True 0])+ b "bool" E.bool True,+ b "int2" E.int2 (Left 1000),+ b "int4" E.int4 (Left 1000),+ b "int8" E.int8 (Left 1000),+ b "float4" E.float4 12.65468468,+ b "float8" E.float8 12.65468468,+ b "numeric" E.numeric (read "20.213290183"),+ b "char" E.char 'Я',+ b "text" E.text (Left "alsdjflskjдывлоаы оады"),+ b "bytea" E.bytea (Left "alskdfj;dasjfl;dasjflksdj"),+ b "date" E.date (read "2000-01-19"),+ b "time" (E.time True) (read "10:41:06"),+ b "timetz" (E.timetz True) (read "(10:41:06, +0300)"),+ b "timestamp" (E.timestamp True) (read "2000-01-19 10:41:06"),+ b "timestamptz" (E.timestamptz True) (read "2000-01-19 10:41:06"),+ b "interval" E.interval (secondsToDiffTime 23472391128374),+ b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"),+ b "array" E.array (Array.fromListUnsafe + [Array.fromSingleton (Just "dfs") True 0,+ Array.fromSingleton Nothing True 0]) ] where b name encoder value =
executables/Tests.hs view
@@ -45,12 +45,17 @@ unsafePerformIO $ do c <- connect initConnection c- Just result <-+ result <- let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> encode v <*> pure PQ.Binary in PQ.execParams c "SELECT $1" [param] PQ.Binary- binaryResult <- PQ.getvalue result 0 0- PQ.finish c- return $ decode binaryResult+ case result of+ Just result -> do+ binaryResult <- PQ.getvalue result 0 0+ PQ.finish c+ return $ decode binaryResult+ Nothing -> do+ m <- PQ.errorMessage c+ fail $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> show m) m mappingTextP :: (Show a, Eq a) => @@ -199,6 +204,36 @@ minInterval :: DiffTime = negate maxInterval +integerDatetimes :: Bool+integerDatetimes =+ unsafePerformIO $ do+ connection <- connect+ initConnection connection+ integerDatetimes <- getIntegerDatetimes connection+ PQ.finish connection+ return integerDatetimes++-- * Misc+-------------------------++timestamptzApxRep (UTCTime d d') =+ (d, picoApxRep (unsafeCoerce d'))++timestampApxRep (LocalTime d t) =+ (d, timeApxRep t)++timetzApxRep (t, tz) = + (timeApxRep t, tz)++timeApxRep (TimeOfDay h m s) =+ (h, m, picoApxRep s)++picoApxRep :: Pico -> Integer+picoApxRep s =+ let p = unsafeCoerce s :: Integer+ in round (p % 10^6)++ -- * Tests ------------------------- @@ -255,46 +290,49 @@ query "SELECT $1" [Just p] PQ.Binary prop_timestamp =- forAll microsUTCTimeGen $ - mappingP (PTI.oidOf PTI.timestamp) - (nonNullRenderer Encoder.timestamp)- (nonNullParser Decoder.timestamp)+ forAll microsLocalTimeGen $ \x ->+ Just (Right (timestampApxRep x)) === do+ unsafePerformIO $ do+ let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timestamp)+ (Encoder.timestamp integerDatetimes x)+ (PQ.Binary)+ in (fmap . fmap) (fmap timestampApxRep . Decoder.timestamp integerDatetimes)+ (query "SELECT $1" [Just p] PQ.Binary) test_timestampParsing1 =- assertEqual (Right (read "2000-01-19 10:41:06" :: UTCTime)) =<< do- fmap (Decoder.timestamp . fromJust) $ + assertEqual (Right (read "2000-01-19 10:41:06" :: LocalTime)) =<< do+ fmap (Decoder.timestamp integerDatetimes . fromJust) $ query "SELECT '2000-01-19 10:41:06' :: timestamp" [] PQ.Binary prop_timestamptz =- forAll microsLocalTimeGen $ - mappingP (PTI.oidOf PTI.timestamptz) - (nonNullRenderer Encoder.timestamptz)- (nonNullParser Decoder.timestamptz)+ forAll microsUTCTimeGen $ \x ->+ Just (Right (timestamptzApxRep x)) === do+ unsafePerformIO $ do+ let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timestamptz)+ (Encoder.timestamptz integerDatetimes x)+ (PQ.Binary)+ in (fmap . fmap) (fmap timestamptzApxRep . Decoder.timestamptz integerDatetimes)+ (query "SELECT $1" [Just p] PQ.Binary) prop_timetz = forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ \x ->- Right x === do+ Just (Right (timetzApxRep x)) === do unsafePerformIO $ do- connection <- connect- initConnection connection- integerDatetimes <- getIntegerDatetimes connection- Just result <- - let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timetz, Encoder.timetz integerDatetimes x, PQ.Binary)]- in PQ.execParams connection "SELECT $1" params PQ.Binary- encodedResult <- PQ.getvalue result 0 0- PQ.finish connection- return $ - Decoder.timetz integerDatetimes (fromJust encodedResult)+ let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timetz)+ (Encoder.timetz integerDatetimes x)+ (PQ.Binary)+ in (fmap . fmap) (fmap timetzApxRep . Decoder.timetz integerDatetimes)+ (query "SELECT $1" [Just p] PQ.Binary) test_timetzParsing =- assertEqual (Right (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do+ assertEqual (Right $ timetzApxRep (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do connection <- connect initConnection connection integerDatetimes <- getIntegerDatetimes connection Just result <- PQ.execParams connection "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary encodedResult <- PQ.getvalue result 0 0 PQ.finish connection- return $ + return $ fmap timetzApxRep $ Decoder.timetz integerDatetimes (fromJust encodedResult) prop_timeFromIntegerIsomorphism =@@ -311,7 +349,7 @@ prop_time = forAll microsTimeOfDayGen $ \x ->- Right x === do+ Right (timeApxRep x) === do unsafePerformIO $ do connection <- connect initConnection connection@@ -321,12 +359,12 @@ in PQ.execParams connection "SELECT $1" params PQ.Binary encodedResult <- PQ.getvalue result 0 0 PQ.finish connection- return $ + return $ fmap timeApxRep $ Decoder.time integerDatetimes (fromJust encodedResult) prop_timeParsing = forAll microsTimeOfDayGen $ \x ->- Right x === do+ Right (timeApxRep x) === do unsafePerformIO $ do connection <- connect initConnection connection@@ -336,7 +374,7 @@ in PQ.execParams connection "SELECT $1" params PQ.Binary encodedResult <- PQ.getvalue result 0 0 PQ.finish connection- return $ + return $ fmap timeApxRep $ Decoder.time integerDatetimes (fromJust encodedResult) prop_scientific (c, e) =
library/PostgreSQLBinary/Decoder.hs view
@@ -36,12 +36,12 @@ {-# INLINABLE float4 #-} float4 :: D Float float4 =- unsafeCoerce . (int :: D Word32)+ unsafeCoerce (int :: D Word32) {-# INLINABLE float8 #-} float8 :: D Double float8 =- unsafeCoerce . (int :: D Word64)+ unsafeCoerce (int :: D Word64) {-# INLINABLE numeric #-} numeric :: D Scientific@@ -89,7 +89,7 @@ True -> fmap Time.microsToTimeOfDay . int False ->- fmap Time.secondsToTimeOfDay . float8+ fmap Time.secsToTimeOfDay . float8 -- | -- Decoding strategy depends on whether the server supports @integer_datetimes@.@@ -103,33 +103,27 @@ tz = fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32) -{-# INLINABLE timestamp #-}-timestamp :: D UTCTime+-- |+-- Decoding strategy depends on whether the server supports @integer_datetimes@.+{-# INLINABLE timestamptz #-}+timestamp :: Bool -> D LocalTime timestamp =- fmap fromMicros . int- where- fromMicros =- evalState $ do- days <- state $ (`divMod` (10^6 * 60 * 60 * 24))- micros <- get- return $- UTCTime - (Time.postgresJulianToDay days)- (picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros)+ \case+ True ->+ fmap Time.microsToLocalTime . int+ False ->+ fmap Time.secsToLocalTime . float8 -{-# INLINABLE timestamptz #-}-timestamptz :: D LocalTime+-- |+-- Decoding strategy depends on whether the server supports @integer_datetimes@.+{-# INLINABLE timestamp #-}+timestamptz :: Bool -> D UTCTime timestamptz =- fmap fromMicros . int- where- fromMicros =- evalState $ do- days <- state $ (`divMod` (10^6 * 60 * 60 * 24))- micros <- get- return $- LocalTime - (Time.postgresJulianToDay days)- (Time.microsToTimeOfDay micros)+ \case+ True ->+ fmap Time.microsToUTC . int+ False ->+ fmap Time.secsToUTC . float8 {-# INLINABLE interval #-} interval :: D DiffTime
library/PostgreSQLBinary/Encoder.hs view
@@ -126,14 +126,18 @@ Integral.unpackBySize 4 . (*60) . negate . timeZoneMinutes {-# INLINABLE timestamp #-}-timestamp :: E UTCTime+timestamp :: Bool -> E LocalTime timestamp =- Builder.run . Builder.timestamp+ \case+ True -> int8 . Left . Time.localTimeToMicros+ False -> float8 . Time.localTimeToSecs {-# INLINABLE timestamptz #-}-timestamptz :: E LocalTime+timestamptz :: Bool -> E UTCTime timestamptz =- Builder.run . Builder.timestamptz+ \case+ True -> int8 . Left . Time.utcToMicros+ False -> float8 . Time.utcToSecs {-# INLINABLE interval #-} interval :: E DiffTime
library/PostgreSQLBinary/Encoder/Builder.hs view
@@ -55,20 +55,6 @@ date = int32BE . fromIntegral . Time.dayToPostgresJulian -{-# INLINE timestamp #-}-timestamp :: UTCTime -> Builder-timestamp (UTCTime dayX timeX) =- let days = Time.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24- time = (`div` (10^6)) . unsafeCoerce $ timeX- in int64BE $ fromIntegral $ days + time--{-# INLINE timestamptz #-}-timestamptz :: LocalTime -> Builder-timestamptz (LocalTime dayX timeX) =- let days = Time.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24- time = (`div` (10^6)) . unsafeCoerce timeOfDayToTime $ timeX- in int64BE $ fromIntegral $ days + time- {-# INLINE interval #-} interval :: DiffTime -> Builder interval =@@ -80,11 +66,11 @@ {-# INLINE numeric #-} numeric :: Scientific -> Builder numeric x =- word16BE (fromIntegral componentsAmount) <>+ int16BE (fromIntegral componentsAmount) <> int16BE (fromIntegral pointIndex) <>- word16BE signCode <>- word16BE (fromIntegral trimmedExponent) <>- foldMap word16BE components+ int16BE signCode <>+ int16BE (fromIntegral trimmedExponent) <>+ foldMap int16BE components where componentsAmount = length components
library/PostgreSQLBinary/Interval.hs view
@@ -17,7 +17,7 @@ -- Oddly enough despite a claim of support of up to 178000000 years in -- <http://www.postgresql.org/docs/9.3/static/datatype-datetime.html Postgres' docs> -- in practice it starts behaving unpredictably after a smaller limit.-maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.year+maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros minDiffTime :: DiffTime = negate maxDiffTime fromDiffTime :: DiffTime -> Maybe Interval
library/PostgreSQLBinary/Numeric.hs view
@@ -3,12 +3,12 @@ import PostgreSQLBinary.Prelude -posSignCode = 0x0000 :: Word16-negSignCode = 0x4000 :: Word16-nanSignCode = 0xC000 :: Word16+posSignCode = 0x0000 :: Int16+negSignCode = 0x4000 :: Int16+nanSignCode = 0xC000 :: Int16 {-# INLINE extractComponents #-}-extractComponents :: Integral a => a -> [Word16]+extractComponents :: Integral a => a -> [Int16] extractComponents = (reverse .) . (. abs) . unfoldr $ \case 0 -> Nothing@@ -28,7 +28,7 @@ -- | -- Unpack a component into digits. {-# INLINE componentDigits #-}-componentDigits :: Word16 -> [Word16]+componentDigits :: Int16 -> [Int16] componentDigits = evalState $ do a <- state (`divMod` 1000)
library/PostgreSQLBinary/Prelude.hs view
@@ -14,9 +14,11 @@ ------------------------- import BasePrelude as Exports --- mtl-prelude+-- transformers --------------------------import MTLPrelude as Exports hiding (shift)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.Class as Exports -- text -------------------------
library/PostgreSQLBinary/Time.hs view
@@ -4,62 +4,121 @@ import Data.Time.Calendar.Julian -type YMD = (Integer, Int, Int)--{-# INLINE dayToJulianYMD #-}-dayToJulianYMD :: Day -> YMD-dayToJulianYMD = - toJulian--{-# INLINE dayToGregorianYMD #-}-dayToGregorianYMD :: Day -> YMD-dayToGregorianYMD = - toGregorian--{-# INLINABLE ymdToInt #-}-ymdToInt :: YMD -> Int-ymdToInt (y, m, d) =- let (m', y') = if m > 2 then (m + 1, fromIntegral $ y + 4800)- else (m + 13, fromIntegral $ y + 4799)- century = y' `div` 100- in - y' * 365 - 32167 + - y' `div` 4 - century + century `div` 4 + - 7834 * m' `div` 256 + d- {-# INLINABLE dayToPostgresJulian #-} dayToPostgresJulian :: Day -> Integer dayToPostgresJulian = (+ (2400001 - 2451545)) . toModifiedJulianDay {-# INLINABLE postgresJulianToDay #-}-postgresJulianToDay :: Int -> Day+postgresJulianToDay :: Int64 -> Day postgresJulianToDay = ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) {-# INLINABLE microsToTimeOfDay #-}-microsToTimeOfDay :: Int -> TimeOfDay+microsToTimeOfDay :: Int64 -> TimeOfDay microsToTimeOfDay = evalState $ do- h <- state $ flip divMod (10 ^ 6 * 60 * 60)- m <- state $ flip divMod (10 ^ 6 * 60)+ h <- state $ flip divMod $ 10 ^ 6 * 60 * 60+ m <- state $ flip divMod $ 10 ^ 6 * 60 u <- get- let p = fromIntegral u * 10 ^ 6 :: Integer return $- TimeOfDay h m (unsafeCoerce p)+ TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) -{-# INLINABLE secondsToTimeOfDay #-}-secondsToTimeOfDay :: Double -> TimeOfDay-secondsToTimeOfDay =+{-# INLINABLE microsToUTC #-}+microsToUTC :: Int64 -> UTCTime+microsToUTC = evalState $ do- h <- state $ flip divMod' (60 * 60)- m <- state $ flip divMod' (60)+ d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+ u <- get+ return $+ UTCTime (postgresJulianToDay d) (microsToDiffTime u)++{-# INLINABLE microsToPico #-}+microsToPico :: Int64 -> Pico+microsToPico =+ unsafeCoerce . (* (10^6)) . (fromIntegral :: Int64 -> Integer)++{-# INLINABLE microsToDiffTime #-}+microsToDiffTime :: Int64 -> DiffTime+microsToDiffTime =+ unsafeCoerce microsToPico++{-# INLINABLE microsToLocalTime #-}+microsToLocalTime :: Int64 -> LocalTime+microsToLocalTime =+ evalState $ do+ d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+ u <- get+ return $+ LocalTime (postgresJulianToDay d) (microsToTimeOfDay u)++{-# INLINABLE secsToTimeOfDay #-}+secsToTimeOfDay :: Double -> TimeOfDay+secsToTimeOfDay =+ evalState $ do+ h <- state $ flip divMod' $ 60 * 60+ m <- state $ flip divMod' $ 60 s <- get- let p = truncate $ toRational s * 10 ^ 12 :: Integer return $- TimeOfDay h m (unsafeCoerce p)+ TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s) +{-# INLINABLE secsToUTC #-}+secsToUTC :: Double -> UTCTime+secsToUTC =+ evalState $ do+ d <- state $ flip divMod' $ 60 * 60 * 24+ s <- get+ return $+ UTCTime (postgresJulianToDay d) (secsToDiffTime s) +{-# INLINABLE secsToLocalTime #-}+secsToLocalTime :: Double -> LocalTime+secsToLocalTime =+ evalState $ do+ d <- state $ flip divMod' $ 60 * 60 * 24+ s <- get+ return $+ LocalTime (postgresJulianToDay d) (secsToTimeOfDay s)++{-# INLINABLE secsToPico #-}+secsToPico :: Double -> Pico+secsToPico s =+ unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer)++{-# INLINABLE secsToDiffTime #-}+secsToDiffTime :: Double -> DiffTime+secsToDiffTime =+ unsafeCoerce secsToPico++{-# INLINABLE localTimeToMicros #-}+localTimeToMicros :: LocalTime -> Int64+localTimeToMicros (LocalTime dayX timeX) =+ let d = dayToPostgresJulian dayX+ p = unsafeCoerce $ timeOfDayToTime timeX+ in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))++{-# INLINABLE localTimeToSecs #-}+localTimeToSecs :: LocalTime -> Double+localTimeToSecs (LocalTime dayX timeX) =+ let d = dayToPostgresJulian dayX+ p = unsafeCoerce $ timeOfDayToTime timeX+ in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))++{-# INLINABLE utcToMicros #-}+utcToMicros :: UTCTime -> Int64+utcToMicros (UTCTime dayX diffTimeX) =+ let d = dayToPostgresJulian dayX+ p = unsafeCoerce diffTimeX+ in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))++{-# INLINABLE utcToSecs #-}+utcToSecs :: UTCTime -> Double+utcToSecs (UTCTime dayX diffTimeX) =+ let d = dayToPostgresJulian dayX+ p = unsafeCoerce diffTimeX+ in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))++ -- * Constants in microseconds according to Julian dates standard ------------------------- -- According to@@ -67,12 +126,9 @@ -- Postgres uses Julian dates internally ------------------------- -year :: Int64 = truncate (365.2425 * fromIntegral day :: Rational)-day :: Int64 = 24 * hour-hour :: Int64 = 60 * minute-minute :: Int64 = 60 * second-second :: Int64 = 10 ^ 6 +yearMicros :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational)+dayMicros :: Int64 = 24 * hourMicros+hourMicros :: Int64 = 60 * minuteMicros+minuteMicros :: Int64 = 60 * secondMicros+secondMicros :: Int64 = 10 ^ 6 -microsToDiffTime :: Int64 -> DiffTime-microsToDiffTime =- unsafeCoerce . (* (10^6)) . fromIntegral
postgresql-binary.cabal view
@@ -1,7 +1,7 @@ name: postgresql-binary version:- 0.2.3+ 0.3.0 synopsis: Encoders and decoders for the PostgreSQL's binary format description:@@ -10,6 +10,9 @@ It can be used to implement high level APIs for Postgres. E.g., <http://hackage.haskell.org/package/hasql-postgres "hasql-postgres"> is based on this library.+ .+ It's tested against Postgres versions 8.3 and 9.3+ with the @integer_datetimes@ setting off and on. category: Database, Codecs, Parsing homepage:@@ -73,7 +76,7 @@ loch-th == 0.2.*, placeholders == 0.1.*, -- general:- mtl-prelude < 3,+ transformers >= 0.2 && < 0.5, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8