postgresql-binary 0.1.0 → 0.2.0
raw patch · 9 files changed
+213/−125 lines, 9 files
Files
- executables/Decoding.hs +2/−2
- executables/Encoding.hs +20/−20
- executables/Tests.hs +82/−23
- library/PostgreSQLBinary/Date.hs +0/−39
- library/PostgreSQLBinary/Decoder.hs +20/−13
- library/PostgreSQLBinary/Encoder.hs +23/−7
- library/PostgreSQLBinary/Encoder/Builder.hs +4/−19
- library/PostgreSQLBinary/Time.hs +60/−0
- postgresql-binary.cabal +2/−2
executables/Decoding.hs view
@@ -28,8 +28,8 @@ b "text" D.text (E.text (Left "alsdjflskjдывлоаы оады")), b "bytea" D.bytea (E.bytea (Left "alskdfj;dasjfl;dasjflksdj")), b "date" D.date (E.date (read "2000-01-19")),- b "time" D.time (E.time (read "10:41:06")),- b "timetz" D.timetz (E.timetz (read "(10:41:06, +0300)")),+ 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)),
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 (read "10:41:06"),- b "timetz" E.timetz (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 (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]) ] where b name encoder value =
executables/Tests.hs view
@@ -105,12 +105,20 @@ initConnection :: PQ.Connection -> IO () initConnection c = void $ PQ.exec c $ mconcat $ map (<> ";") $ - [ "SET standard_conforming_strings TO on",- "SET datestyle TO ISO",- "SET client_encoding = 'UTF8'",+ [ "SET client_min_messages TO WARNING",- "SET bytea_output = 'hex'" ]+ "SET client_encoding = 'UTF8'"+ ] +getIntegerDatetimes :: PQ.Connection -> IO Bool+getIntegerDatetimes c =+ fmap parseResult $ PQ.parameterStatus c "integer_datetimes"+ where+ parseResult = + \case+ Just "on" -> True+ _ -> False+ nonNullParser p = fromMaybe (Left "Unexpected NULL") . fmap p @@ -177,9 +185,18 @@ dimensionWidth (x, _) = fromIntegral x --- * Properties+-- * Tests ------------------------- +-- | This is a dummy, the sole point of which is to output the value of 'integer_datetimes'+test_integerDatetimes =+ do+ connection <- connect+ initConnection connection+ x <- getIntegerDatetimes connection+ putStrLn $ "'integer_datetimes' is " <> show x+ PQ.finish connection+ prop_uuid = forAll uuidGen $ mappingP (PTI.oidOf PTI.uuid) @@ -220,30 +237,72 @@ (nonNullParser Decoder.timestamptz) prop_timetz =- forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ - mappingP (PTI.oidOf PTI.timetz) - (nonNullRenderer Encoder.timetz)- (nonNullParser Decoder.timetz)+ forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ \x ->+ Right 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) -test_timetzParsing1 =+test_timetzParsing = assertEqual (Right (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do- fmap (Decoder.timetz . fromJust) $ - query "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary+ 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 $ + Decoder.timetz integerDatetimes (fromJust encodedResult) -prop_timeOfDay =- forAll microsTimeOfDayGen $ - mappingP (PTI.oidOf PTI.time) - (nonNullRenderer Encoder.time)- (nonNullParser Decoder.time)+prop_timeFromIntegerIsomorphism =+ forAll microsTimeOfDayGen $ \x ->+ Right x === Decoder.time True (Encoder.time True x) -prop_timeOfDayParsing =+prop_timeFromDoubleIsomorphism = forAll microsTimeOfDayGen $ \x ->+ let Right x' = Decoder.time False (Encoder.time False x)+ in floatEqProp (toFloat x) (toFloat x')+ where+ toFloat (TimeOfDay h m s) =+ s + fromIntegral (60 * (m + 60 * h))++prop_time =+ forAll microsTimeOfDayGen $ \x -> Right x === do- unsafePerformIO $ - fmap (Decoder.time . fromJust) $ - query "SELECT $1" - [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)] - PQ.Binary+ unsafePerformIO $ do+ connection <- connect+ initConnection connection+ integerDatetimes <- getIntegerDatetimes connection+ Just result <- + let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, Encoder.time integerDatetimes x, PQ.Binary)]+ in PQ.execParams connection "SELECT $1" params PQ.Binary+ encodedResult <- PQ.getvalue result 0 0+ PQ.finish connection+ return $ + Decoder.time integerDatetimes (fromJust encodedResult)++prop_timeParsing =+ forAll microsTimeOfDayGen $ \x ->+ Right x === do+ unsafePerformIO $ do+ connection <- connect+ initConnection connection+ integerDatetimes <- getIntegerDatetimes connection+ Just result <- + let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)]+ in PQ.execParams connection "SELECT $1" params PQ.Binary+ encodedResult <- PQ.getvalue result 0 0+ PQ.finish connection+ return $ + Decoder.time integerDatetimes (fromJust encodedResult) prop_scientific (c, e) = let x = Scientific.scientific c e
− library/PostgreSQLBinary/Date.hs
@@ -1,39 +0,0 @@-module PostgreSQLBinary.Date where--import PostgreSQLBinary.Prelude-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 :: Integer -> Day-postgresJulianToDay =- ModifiedJulianDay . (subtract (2400001 - 2451545))-
library/PostgreSQLBinary/Decoder.hs view
@@ -13,7 +13,7 @@ import qualified PostgreSQLBinary.Decoder.Atto as Atto import qualified PostgreSQLBinary.Decoder.Zepto as Zepto import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Date as Date+import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Integral as Integral import qualified PostgreSQLBinary.Numeric as Numeric @@ -95,20 +95,27 @@ {-# INLINABLE date #-} date :: D Day date =- fmap (Date.postgresJulianToDay . fromIntegral) . (int :: D Int32)+ fmap (Time.postgresJulianToDay . fromIntegral) . (int :: D Int32) +-- |+-- Decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE time #-}-time :: D TimeOfDay+time :: Bool -> D TimeOfDay time =- fmap (timeToTimeOfDay . picosecondsToDiffTime . (* (10^6)) . fromIntegral) . - (int :: D Word64)+ \case+ True ->+ fmap Time.microsToTimeOfDay . int+ False ->+ fmap Time.secondsToTimeOfDay . float8 +-- |+-- Decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timetz #-}-timetz :: D (TimeOfDay, TimeZone)-timetz =+timetz :: Bool -> D (TimeOfDay, TimeZone)+timetz integer_datetimes = \x -> let (timeX, zoneX) = B.splitAt 8 x- in (,) <$> time timeX <*> tz zoneX+ in (,) <$> time integer_datetimes timeX <*> tz zoneX where tz = fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32)@@ -116,7 +123,7 @@ {-# INLINABLE timestamp #-} timestamp :: D UTCTime timestamp =- fmap fromMicros . (int :: D Int64)+ fmap fromMicros . int where fromMicros = evalState $ do@@ -124,13 +131,13 @@ micros <- get return $ UTCTime - (Date.postgresJulianToDay . fromIntegral $ days)+ (Time.postgresJulianToDay days) (picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros) {-# INLINABLE timestamptz #-} timestamptz :: D LocalTime timestamptz =- fmap fromMicros . (int :: D Int64)+ fmap fromMicros . int where fromMicros = evalState $ do@@ -138,8 +145,8 @@ micros <- get return $ LocalTime - (Date.postgresJulianToDay . fromIntegral $ days)- (timeToTimeOfDay . picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros)+ (Time.postgresJulianToDay days)+ (Time.microsToTimeOfDay micros) {-# INLINABLE interval #-} interval :: D DiffTime
library/PostgreSQLBinary/Encoder.hs view
@@ -12,7 +12,7 @@ import qualified Data.Text.Lazy.Encoding as TLE import qualified PostgreSQLBinary.Encoder.Builder as Builder import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Date as Date+import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Integral as Integral import qualified PostgreSQLBinary.Numeric as Numeric @@ -99,15 +99,31 @@ date = Builder.run . Builder.date +-- |+-- Encoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE time #-}-time :: E TimeOfDay-time =- Builder.run . Builder.time+time :: Bool -> E TimeOfDay+time integer_datetimes (TimeOfDay h m s) =+ let+ p = unsafeCoerce s :: Integer+ u = p `div` (10^6)+ in if integer_datetimes+ then+ Integral.unpackBySize 8 $+ fromIntegral u + 10^6 * 60 * (m + 60 * h)+ else+ inline float8 $+ fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h)) +-- |+-- Encoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timetz #-}-timetz :: E (TimeOfDay, TimeZone)-timetz =- Builder.run . Builder.timetz+timetz :: Bool -> E (TimeOfDay, TimeZone)+timetz integer_datetimes (timeX, tzX) =+ inline time integer_datetimes timeX <> tz tzX+ where+ tz =+ Integral.unpackBySize 4 . (*60) . negate . timeZoneMinutes {-# INLINABLE timestamp #-} timestamp :: E UTCTime
library/PostgreSQLBinary/Encoder/Builder.hs view
@@ -13,7 +13,7 @@ import qualified Data.Scientific as Scientific import qualified Data.UUID as UUID import qualified PostgreSQLBinary.Array as Array-import qualified PostgreSQLBinary.Date as Date+import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Numeric as Numeric @@ -52,34 +52,19 @@ {-# INLINE date #-} date :: Day -> Builder date =- int32BE . fromIntegral . Date.dayToPostgresJulian--{-# INLINE time #-}-time :: TimeOfDay -> Builder-time =- word64BE . (`div` (10^6)) . unsafeCoerce timeOfDayToTime--{-# INLINE timetz #-}-timetz :: (TimeOfDay, TimeZone) -> Builder-timetz (timeX, tzX) =- time timeX <> tz tzX--{-# INLINE tz #-}-tz :: TimeZone -> Builder-tz =- int32BE . fromIntegral . (*60) . negate . timeZoneMinutes+ int32BE . fromIntegral . Time.dayToPostgresJulian {-# INLINE timestamp #-} timestamp :: UTCTime -> Builder timestamp (UTCTime dayX timeX) =- let days = Date.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24+ 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 = Date.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24+ let days = Time.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 time = (`div` (10^6)) . unsafeCoerce timeOfDayToTime $ timeX in int64BE $ fromIntegral $ days + time
+ library/PostgreSQLBinary/Time.hs view
@@ -0,0 +1,60 @@+module PostgreSQLBinary.Time where++import PostgreSQLBinary.Prelude+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 =+ ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545)++{-# INLINABLE microsToTimeOfDay #-}+microsToTimeOfDay :: Int -> TimeOfDay+microsToTimeOfDay =+ evalState $ do+ 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)++{-# INLINABLE secondsToTimeOfDay #-}+secondsToTimeOfDay :: Double -> TimeOfDay+secondsToTimeOfDay =+ 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)
postgresql-binary.cabal view
@@ -1,7 +1,7 @@ name: postgresql-binary version:- 0.1.0+ 0.2.0 synopsis: Encoders and decoders for the PostgreSQL's binary format description:@@ -55,7 +55,7 @@ PostgreSQLBinary.Decoder.Zepto PostgreSQLBinary.Integral PostgreSQLBinary.Numeric- PostgreSQLBinary.Date+ PostgreSQLBinary.Time exposed-modules: PostgreSQLBinary.Array PostgreSQLBinary.Encoder