diff --git a/decoding/Main.hs b/decoding/Main.hs new file mode 100644 --- /dev/null +++ b/decoding/Main.hs @@ -0,0 +1,69 @@ +module Main where + +import BasePrelude +import MTLPrelude +import Control.DeepSeq +import Criterion +import Criterion.Main +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Scientific (Scientific) +import Data.Time +import qualified PostgreSQL.Binary.Encoder as E +import qualified PostgreSQL.Binary.Decoder as D + + +main = + defaultMain + [ + b "bool" D.bool (E.run E.bool True) + , + b "int2" (D.int :: D.Decoder Int16) (E.run E.int2_int16 1000) + , + b "int4" (D.int :: D.Decoder Int32) (E.run E.int4_int32 1000) + , + b "int8" (D.int :: D.Decoder Int64) (E.run E.int8_int64 1000) + , + b "float4" D.float4 (E.run E.float4 12.65468468) + , + b "float8" D.float8 (E.run E.float8 12.65468468) + , + b "numeric" D.numeric (E.run E.numeric (read "20.213290183")) + , + b "char" D.char (E.run E.char 'Я') + , + b "text" D.text_strict (E.run E.text_strict "alsdjflskjдывлоаы оады") + , + b "bytea" D.bytea_strict (E.run E.bytea_strict "alskdfj;dasjfl;dasjflksdj") + , + b "date" D.date (E.run E.date (read "2000-01-19")) + , + b "time" D.time_int (E.run E.time_int (read "10:41:06")) + , + b "timetz" D.timetz_int (E.run E.timetz_int (read "(10:41:06, +0300)")) + , + b "timestamp" D.timestamp_int (E.run E.timestamp_int (read "2000-01-19 10:41:06")) + , + b "timestamptz" D.timestamptz_int (E.run E.timestamptz_int (read "2000-01-19 10:41:06")) + , + b "interval" D.interval_int (E.run E.interval_int (secondsToDiffTime 23472391128374)) + , + b "uuid" D.uuid (E.run E.uuid (read "550e8400-e29b-41d4-a716-446655440000")) + , + let + encoder = + E.array 23 $ + E.arrayDimension foldl' $ + E.arrayValue $ + E.int4_int32 + decoder = + D.array $ + D.arrayDimension replicateM $ + D.arrayNonNullValue $ + (D.int :: D.Decoder Int32) + in + b "array" decoder (E.run encoder [1,2,3,4]) + ] + where + b name decoder value = + bench name $ nf (D.run decoder) value diff --git a/encoding/Main.hs b/encoding/Main.hs new file mode 100644 --- /dev/null +++ b/encoding/Main.hs @@ -0,0 +1,63 @@ +module Main where + +import BasePrelude +import MTLPrelude +import Control.DeepSeq +import Criterion +import Criterion.Main +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Scientific (Scientific) +import Data.Time +import qualified PostgreSQL.Binary.Encoder as E + + +main = + defaultMain + [ + b "bool" E.bool True + , + b "int2" E.int2_int16 1000 + , + b "int4" E.int4_int32 1000 + , + b "int8" E.int8_int64 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_strict "alsdjflskjдывлоаы оады" + , + b "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj" + , + b "date" E.date (read "2000-01-19") + , + b "time" E.time_int (read "10:41:06") + , + b "timetz" E.timetz_int (read "(10:41:06, +0300)") + , + b "timestamp" E.timestamp_int (read "2000-01-19 10:41:06") + , + b "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06") + , + b "interval" E.interval_int (secondsToDiffTime 23472391128374) + , + b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000") + , + let + encoder = + E.array 23 $ + E.arrayDimension foldl' $ + E.arrayValue $ + E.int4_int32 + in + b "array" encoder [1,2,3,4] + ] + where + b name encoder value = + bench name $ nf (E.run encoder) value diff --git a/executables/Decoding.hs b/executables/Decoding.hs deleted file mode 100644 --- a/executables/Decoding.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Main where - -import BasePrelude -import MTLPrelude -import Control.DeepSeq -import Criterion -import Criterion.Main -import Data.Text (Text) -import Data.ByteString (ByteString) -import Data.Scientific (Scientific) -import Data.Time -import qualified PostgreSQLBinary.Encoder as E -import qualified PostgreSQLBinary.Decoder as D -import qualified PostgreSQLBinary.Array as Array - - -main = - defaultMain - [ - b "bool" D.bool (E.bool True), - b "int2" (D.int :: D.D Int16) (E.int2 (Left 1000)), - b "int4" (D.int :: D.D Int32) (E.int4 (Left 1000)), - b "int8" (D.int :: D.D Int64) (E.int8 (Left 1000)), - b "float4" D.float4 (E.float4 12.65468468), - b "float8" D.float8 (E.float8 12.65468468), - b "numeric" D.numeric (E.numeric (read "20.213290183")), - b "char" D.char (E.char 'Я'), - 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 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 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 True) (E.interval True (secondsToDiffTime 23472391128374)), - b "uuid" D.uuid (E.uuid (read "550e8400-e29b-41d4-a716-446655440000")), - b "array" D.array (E.array - (Array.fromListUnsafe - [Array.fromSingleton (Just "dfs") True 0, - Array.fromSingleton Nothing True 0])) - ] - where - b name decoder value = - bench name $ nf decoder value diff --git a/executables/Encoding.hs b/executables/Encoding.hs deleted file mode 100644 --- a/executables/Encoding.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Main where - -import BasePrelude -import MTLPrelude -import Control.DeepSeq -import Criterion -import Criterion.Main -import Data.Text (Text) -import Data.ByteString (ByteString) -import Data.Scientific (Scientific) -import Data.Time -import qualified PostgreSQLBinary.Encoder as E -import qualified PostgreSQLBinary.Decoder as D -import qualified PostgreSQLBinary.Array as Array - - -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 True) (read "2000-01-19 10:41:06"), - b "timestamptz" (E.timestamptz True) (read "2000-01-19 10:41:06"), - b "interval" (E.interval True) (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 = - bench name $ nf encoder value diff --git a/executables/PostgreSQLBinary/PTI.hs b/executables/PostgreSQLBinary/PTI.hs deleted file mode 100644 --- a/executables/PostgreSQLBinary/PTI.hs +++ /dev/null @@ -1,77 +0,0 @@ -module PostgreSQLBinary.PTI where - -import BasePrelude - - --- | A Postgresql type info -data PTI = PTI { oidOf :: !Word32, arrayOIDOf :: !(Maybe Word32) } - -abstime = PTI 702 (Just 1023) -aclitem = PTI 1033 (Just 1034) -bit = PTI 1560 (Just 1561) -bool = PTI 16 (Just 1000) -box = PTI 603 (Just 1020) -bpchar = PTI 1042 (Just 1014) -bytea = PTI 17 (Just 1001) -char = PTI 18 (Just 1002) -cid = PTI 29 (Just 1012) -cidr = PTI 650 (Just 651) -circle = PTI 718 (Just 719) -cstring = PTI 2275 (Just 1263) -date = PTI 1082 (Just 1182) -daterange = PTI 3912 (Just 3913) -float4 = PTI 700 (Just 1021) -float8 = PTI 701 (Just 1022) -gtsvector = PTI 3642 (Just 3644) -inet = PTI 869 (Just 1041) -int2 = PTI 21 (Just 1005) -int2vector = PTI 22 (Just 1006) -int4 = PTI 23 (Just 1007) -int4range = PTI 3904 (Just 3905) -int8 = PTI 20 (Just 1016) -int8range = PTI 3926 (Just 3927) -interval = PTI 1186 (Just 1187) -json = PTI 114 (Just 199) -line = PTI 628 (Just 629) -lseg = PTI 601 (Just 1018) -macaddr = PTI 829 (Just 1040) -money = PTI 790 (Just 791) -name = PTI 19 (Just 1003) -numeric = PTI 1700 (Just 1231) -numrange = PTI 3906 (Just 3907) -oid = PTI 26 (Just 1028) -oidvector = PTI 30 (Just 1013) -path = PTI 602 (Just 1019) -point = PTI 600 (Just 1017) -polygon = PTI 604 (Just 1027) -record = PTI 2249 (Just 2287) -refcursor = PTI 1790 (Just 2201) -regclass = PTI 2205 (Just 2210) -regconfig = PTI 3734 (Just 3735) -regdictionary = PTI 3769 (Just 3770) -regoper = PTI 2203 (Just 2208) -regoperator = PTI 2204 (Just 2209) -regproc = PTI 24 (Just 1008) -regprocedure = PTI 2202 (Just 2207) -regtype = PTI 2206 (Just 2211) -reltime = PTI 703 (Just 1024) -text = PTI 25 (Just 1009) -tid = PTI 27 (Just 1010) -time = PTI 1083 (Just 1183) -timestamp = PTI 1114 (Just 1115) -timestamptz = PTI 1184 (Just 1185) -timetz = PTI 1266 (Just 1270) -tinterval = PTI 704 (Just 1025) -tsquery = PTI 3615 (Just 3645) -tsrange = PTI 3908 (Just 3909) -tstzrange = PTI 3910 (Just 3911) -tsvector = PTI 3614 (Just 3643) -txid_snapshot = PTI 2970 (Just 2949) -unknown = PTI 705 Nothing -uuid = PTI 2950 (Just 2951) -varbit = PTI 1562 (Just 1563) -varchar = PTI 1043 (Just 1015) -void = PTI 2278 Nothing -xid = PTI 28 (Just 1011) -xml = PTI 142 (Just 143) - diff --git a/executables/Tests.hs b/executables/Tests.hs deleted file mode 100644 --- a/executables/Tests.hs +++ /dev/null @@ -1,603 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} -module Main where - -import BasePrelude hiding (assert) -import Test.Framework -import Test.QuickCheck.Instances -import Data.Time -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.Scientific as Scientific -import qualified Data.UUID as UUID -import qualified Database.PostgreSQL.LibPQ as PQ -import qualified PostgreSQLBinary.PTI as PTI -import qualified PostgreSQLBinary.Encoder as Encoder -import qualified PostgreSQLBinary.Decoder as Decoder -import qualified PostgreSQLBinary.Array as Array - - -type Text = T.Text -type LazyText = TL.Text -type ByteString = B.ByteString -type LazyByteString = BL.ByteString -type Scientific = Scientific.Scientific - -main = - htfMain $ htf_thisModulesTests - -floatEqProp :: RealFrac a => Show a => a -> a -> Property -floatEqProp a b = - counterexample (show a ++ " /~ " ++ show b) $ - a + error >= b && a - error <= b - where - error = max (abs a) 1 / 10^3 - -mappingP :: - (Show a, Eq a) => - Word32 -> (a -> Maybe ByteString) -> (Maybe ByteString -> Either Text a) -> a -> Property -mappingP oid encode decode v = - Right v === do - unsafePerformIO $ do - c <- connect - initConnection c - result <- - let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> encode v <*> pure PQ.Binary - in PQ.execParams c "SELECT $1" [param] PQ.Binary - 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) => - Word32 -> (a -> Maybe ByteString) -> (a -> Maybe ByteString) -> a -> Property -mappingTextP oid encode render value = - render value === do unsafePerformIO $ checkText oid (encode value) - -checkText :: Word32 -> Maybe ByteString -> IO (Maybe ByteString) -checkText oid v = - do - c <- connect - initConnection c - Just result <- - let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> v <*> pure PQ.Binary - in PQ.execParams c "SELECT $1" [param] PQ.Text - encodedResult <- PQ.getvalue result 0 0 - PQ.finish c - return $ encodedResult - -query :: ByteString -> [Maybe (PQ.Oid, ByteString, PQ.Format)] -> PQ.Format -> IO (Maybe ByteString) -query statement params outFormat = - do - connection <- connect - initConnection connection - Just result <- PQ.execParams connection statement params outFormat - encodedResult <- PQ.getvalue result 0 0 - PQ.finish connection - return $ encodedResult - -connect :: IO PQ.Connection -connect = - PQ.connectdb bs - where - bs = - B.intercalate " " components - where - components = - [ - "host=" <> host, - "port=" <> (fromString . show) port, - "user=" <> user, - "password=" <> password, - "dbname=" <> db - ] - where - host = "localhost" - port = 5432 - user = "postgres" - password = "" - db = "postgres" - -initConnection :: PQ.Connection -> IO () -initConnection c = - void $ PQ.exec c $ mconcat $ map (<> ";") $ - [ - "SET client_min_messages TO WARNING", - "SET client_encoding = 'UTF8'", - "SET intervalstyle = 'postgres'" - ] - -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 - -nonNullRenderer r = - return . r - --- * Generators -------------------------- - -scientificGen :: Gen Scientific -scientificGen = - Scientific.scientific <$> arbitrary <*> arbitrary - -microsTimeOfDayGen :: Gen TimeOfDay -microsTimeOfDayGen = - fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ - choose (0, (10^6)*24*60*60) - -microsLocalTimeGen :: Gen LocalTime -microsLocalTimeGen = - LocalTime <$> arbitrary <*> microsTimeOfDayGen - -microsUTCTimeGen :: Gen UTCTime -microsUTCTimeGen = - localTimeToUTC <$> timeZoneGen <*> microsLocalTimeGen - -intervalDiffTimeGen :: Gen DiffTime -intervalDiffTimeGen = do - unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer) - where - uMin = unsafeCoerce minInterval `div` 10^6 - uMax = unsafeCoerce maxInterval `div` 10^6 - -timeZoneGen :: Gen TimeZone -timeZoneGen = - minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12) - -uuidGen :: Gen UUID.UUID -uuidGen = - UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - -arrayGen :: Gen (Word32, Array.Data) -arrayGen = - do - ndims <- choose (1, 4) - dims <- replicateM ndims dimGen - (valueGen', oid, arrayOID) <- valueGen - values <- replicateM (dimsToNValues dims) valueGen' - let nulls = elem Nothing values - return (arrayOID, (dims, values, nulls, oid)) - where - dimGen = - (,) <$> choose (1, 7) <*> pure 1 - valueGen = - do - (pti, gen) <- elements [(PTI.int8, mkGen (Encoder.int8 . Left)), - (PTI.bool, mkGen Encoder.bool), - (PTI.date, mkGen Encoder.date), - (PTI.text, mkGen Encoder.text), - (PTI.bytea, mkGen Encoder.bytea)] - return (gen, PTI.oidOf pti, fromJust $ PTI.arrayOIDOf pti) - where - mkGen renderer = - fmap (fmap renderer) arbitrary - dimsToNValues = - product . map dimensionWidth - where - dimensionWidth (x, _) = fromIntegral x - --- * Constants -------------------------- - -maxInterval :: DiffTime = - unsafeCoerce $ - (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) - -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 -------------------------- - --- | 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) - (nonNullRenderer Encoder.uuid) - (nonNullParser Decoder.uuid) - -test_uuidParsing = - assertEqual (Right (read "550e8400-e29b-41d4-a716-446655440000" :: UUID.UUID)) =<< do - fmap (Decoder.uuid . fromJust) $ - query "SELECT '550e8400-e29b-41d4-a716-446655440000' :: uuid" [] PQ.Binary - -test_intervalParsing = - let p = 10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12)))))) - in - assertEqual (Just (Right (picosecondsToDiffTime p))) =<< do - (fmap . fmap) (Decoder.interval integerDatetimes) $ - query "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval" [] PQ.Binary - -prop_interval = - forAll intervalDiffTimeGen $ - mappingP (PTI.oidOf PTI.interval) - (nonNullRenderer (Encoder.interval integerDatetimes)) - (nonNullParser (Decoder.interval integerDatetimes)) - -test_maxInterval = - let x = maxInterval - in - assertEqual (Just (Right x)) =<< do - let - p = - (,,) - (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) - ((Encoder.interval integerDatetimes) x) - (PQ.Binary) - (fmap . fmap) (Decoder.interval integerDatetimes) $ - query "SELECT $1" [Just p] PQ.Binary - -test_minInterval = - let x = minInterval - in - assertEqual (Just (Right x)) =<< do - let - p = - (,,) - (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) - ((Encoder.interval integerDatetimes) x) - (PQ.Binary) - (fmap . fmap) (Decoder.interval integerDatetimes) $ - query "SELECT $1" [Just p] PQ.Binary - -prop_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" :: LocalTime)) =<< do - fmap (Decoder.timestamp integerDatetimes . fromJust) $ - query "SELECT '2000-01-19 10:41:06' :: timestamp" [] PQ.Binary - -test_timestamptzOffset = - do - c <- connect - initConnection c - PQ.exec c "DROP TABLE IF EXISTS a" - PQ.exec c "CREATE TABLE a (b TIMESTAMPTZ)" - PQ.exec c "set timezone to 'America/Los_Angeles'" - let p = (,,) (PQ.Oid $ fromIntegral o) - (Encoder.timestamptz integerDatetimes x) - (PQ.Binary) - o = PTI.oidOf PTI.timestamptz - x = read "2011-09-28 00:17:25" - PQ.execParams c "insert into a (b) values ($1)" [Just p] PQ.Text - PQ.exec c "set timezone to 'Europe/Stockholm'" - assertEqual (Just "2011-09-28 02:17:25+02") - =<< singleResult - =<< PQ.execParams c "SELECT * FROM a" [] PQ.Text - assertEqual (Just (Right x)) - =<< return . fmap (Decoder.timestamptz integerDatetimes) - =<< singleResult - =<< PQ.execParams c "SELECT * FROM a" [] PQ.Binary - where - singleResult r = PQ.getvalue (fromJust r) 0 0 - -prop_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 -> - Just (Right (timetzApxRep x)) === do - unsafePerformIO $ do - 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 $ 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 $ fmap timetzApxRep $ - Decoder.timetz integerDatetimes (fromJust encodedResult) - -prop_timeFromIntegerIsomorphism = - forAll microsTimeOfDayGen $ \x -> - Right x === Decoder.time True (Encoder.time True x) - -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 (timeApxRep x) === do - 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 $ fmap timeApxRep $ - Decoder.time integerDatetimes (fromJust encodedResult) - -prop_timeParsing = - forAll microsTimeOfDayGen $ \x -> - Right (timeApxRep 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 $ fmap timeApxRep $ - Decoder.time integerDatetimes (fromJust encodedResult) - -prop_scientific (c, e) = - let x = Scientific.scientific c e - in - mappingP (PTI.oidOf PTI.numeric) - (nonNullRenderer Encoder.numeric) - (nonNullParser Decoder.numeric) - (x) - -test_scientificParsing1 = - assertEqual (Right (read "-1234560.789" :: Scientific)) =<< do - fmap (Decoder.numeric . fromJust) $ - query "SELECT -1234560.789 :: numeric" [] PQ.Binary - -test_scientificParsing2 = - assertEqual (Right (read "-0.0789" :: Scientific)) =<< do - fmap (Decoder.numeric . fromJust) $ - query "SELECT -0.0789 :: numeric" [] PQ.Binary - -test_scientificParsing3 = - assertEqual (Right (read "10000" :: Scientific)) =<< do - fmap (Decoder.numeric . fromJust) $ - query "SELECT 10000 :: numeric" [] PQ.Binary - -prop_scientificParsing (c, e) = - let x = Scientific.scientific c e - in - Right x === do - unsafePerformIO $ - fmap (Decoder.numeric . fromJust) $ - query "SELECT $1 :: numeric" - [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.numeric, (fromString . show) x, PQ.Text)] - PQ.Binary - -prop_float = - mappingP (PTI.oidOf PTI.float4) - (nonNullRenderer Encoder.float4) - (nonNullParser Decoder.float4) - -prop_floatText = - \x -> - floatEqProp x $ do - fromJust $ unsafePerformIO $ (fmap . fmap) reader $ checkText (PTI.oidOf pti) (encoder x) - where - pti = PTI.float4 - reader = read . BC.unpack - encoder = nonNullRenderer Encoder.float4 - -prop_double = - mappingP (PTI.oidOf PTI.float8) - (nonNullRenderer Encoder.float8) - (nonNullParser Decoder.float8) - -prop_doubleText = - \x -> - floatEqProp x $ do - fromJust $ unsafePerformIO $ (fmap . fmap) reader $ checkText (PTI.oidOf pti) (encoder x) - where - pti = PTI.float8 - reader = read . BC.unpack - encoder = nonNullRenderer Encoder.float8 - -prop_char x = - (x /= '\NUL') ==> - mappingP (PTI.oidOf PTI.text) - (nonNullRenderer Encoder.char) - (nonNullParser Decoder.char) - (x) - -prop_charText x = - (x /= '\NUL') ==> - mappingTextP (PTI.oidOf PTI.text) - (nonNullRenderer Encoder.char) - (Just . TE.encodeUtf8 . T.singleton) - (x) - -test_emptyArrayElements = - assertEqual [] (Array.elements ([], [], False, 0)) - -test_arrayElements = - assertEqual result (Array.elements arrayData) - where - arrayData = ([(3, 1)], [Just "1", Just "2", Just "3"], False, 0) - result = [([], [Just "1"], False, 0), ([], [Just "2"], False, 0), ([], [Just "3"], False, 0)] - -prop_arrayDataFromAndToListIsomporphism = - forAll arrayGen $ \(oid, x) -> - x === (Array.fromListUnsafe . Array.elements) x - -prop_byteString = - mappingP (PTI.oidOf PTI.bytea) - (nonNullRenderer (Encoder.bytea . Left)) - (nonNullParser Decoder.bytea) - -prop_lazyByteString = - mappingP (PTI.oidOf PTI.bytea) - (nonNullRenderer (Encoder.bytea . Right)) - (nonNullParser (fmap BL.fromStrict . Decoder.bytea)) - -prop_text v = - (isNothing $ T.find (== '\NUL') v) ==> - mappingP (PTI.oidOf PTI.text) - (nonNullRenderer (Encoder.text . Left)) - (nonNullParser Decoder.text) - (v) - -prop_lazyText v = - (isNothing $ TL.find (== '\NUL') v) ==> - mappingP (PTI.oidOf PTI.text) - (nonNullRenderer (Encoder.text . Right)) - (nonNullParser (fmap TL.fromStrict . Decoder.text)) - (v) - -prop_bool = - mappingP (PTI.oidOf PTI.bool) - (nonNullRenderer Encoder.bool) - (nonNullParser Decoder.bool) - -prop_int = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Left) . (fromIntegral :: Int -> Int64)) - (nonNullParser Decoder.int) - -prop_int8 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Left) . (fromIntegral :: Int8 -> Int16)) - (nonNullParser Decoder.int) - -prop_int16 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Left)) - (nonNullParser Decoder.int) - -prop_int32 = - mappingP (PTI.oidOf PTI.int4) - (nonNullRenderer (Encoder.int4 . Left)) - (nonNullParser Decoder.int) - -prop_int64 = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Left)) - (nonNullParser Decoder.int) - -prop_int64Text = - mappingTextP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Left)) - (Just . fromString . show) - -prop_word = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Right) . (fromIntegral :: Word -> Word64)) - (nonNullParser Decoder.int) - -prop_word8 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Right) . (fromIntegral :: Word8 -> Word16)) - (nonNullParser Decoder.int) - -prop_word16 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Right)) - (nonNullParser Decoder.int) - -prop_word32 = - mappingP (PTI.oidOf PTI.int4) - (nonNullRenderer (Encoder.int4 . Right)) - (nonNullParser Decoder.int) - -prop_word64 = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Right)) - (nonNullParser Decoder.int) - -prop_word64Text = - mappingTextP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Right)) - (Just . fromString . show) - -prop_day = - mappingP (PTI.oidOf PTI.date) - (nonNullRenderer Encoder.date) - (nonNullParser Decoder.date) - -prop_dayText = - mappingTextP (PTI.oidOf PTI.date) - (nonNullRenderer Encoder.date) - (Just . fromString . show) - -prop_arrayData = - forAll arrayGen $ uncurry $ \oid -> - mappingP (oid) - (nonNullRenderer Encoder.array) - (nonNullParser Decoder.array) - diff --git a/library/PostgreSQL/Binary/BuilderPrim.hs b/library/PostgreSQL/Binary/BuilderPrim.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/BuilderPrim.hs @@ -0,0 +1,10 @@ +module PostgreSQL.Binary.BuilderPrim where + +import PostgreSQL.Binary.Prelude +import qualified Data.ByteString.Builder.Prim as A + + +{-# INLINE nullByteIgnoringBoundedPrim #-} +nullByteIgnoringBoundedPrim :: A.BoundedPrim Word8 +nullByteIgnoringBoundedPrim = + A.condB (== 0) A.emptyB (A.liftFixedToBounded A.word8) diff --git a/library/PostgreSQL/Binary/Data.hs b/library/PostgreSQL/Binary/Data.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Data.hs @@ -0,0 +1,58 @@ +-- | +-- Models of supported data structures according to the serialisation format. +module PostgreSQL.Binary.Data where + +import PostgreSQL.Binary.Prelude + + +-- | +-- A representation of a data serializable to the PostgreSQL array binary format. +-- +-- Consists of a vector of dimensions, a vector of encoded elements, +-- a flag specifying, whether it contains any nulls, and an oid. +type Array = + (Vector ArrayDimension, Vector Content, Bool, OID) + +-- | +-- A width and a lower bound. +-- +-- Currently the lower bound is only allowed to have a value of @1@. +type ArrayDimension = + (Word32, Word32) + +-- | +-- An encoded value. 'Nothing' if it represents a @NULL@. +type Content = + Maybe ByteString + +-- | +-- A Postgres OID of a type. +type OID = + Word32 + +-- | +-- A representation of a composite Postgres data (Record or Row). +type Composite = + Vector (OID, Content) + +-- | +-- HStore. +type HStore = + Vector (ByteString, Content) + +-- | +-- The four components of UUID. +type UUID = + (Word32, Word32, Word32, Word32) + +-- | +-- Representation of the PostgreSQL Numeric encoding. +-- +-- Consists of the following components: +-- +-- * Point index +-- * Sign code +-- * Components +-- +type Numeric = + (Int16, Word16, Vector Int16) diff --git a/library/PostgreSQL/Binary/Decoder.hs b/library/PostgreSQL/Binary/Decoder.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Decoder.hs @@ -0,0 +1,484 @@ +module PostgreSQL.Binary.Decoder +( + Decoder, + run, + -- * Primitive + int, + float4, + float8, + bool, + bytea_strict, + bytea_lazy, + -- * Textual + text_strict, + text_lazy, + char, + -- * Misc + numeric, + uuid, + json, + -- * Time + date, + time_int, + time_float, + timetz_int, + timetz_float, + timestamp_int, + timestamp_float, + timestamptz_int, + timestamptz_float, + interval_int, + interval_float, + -- * Exotic + -- ** Array + ArrayDecoder, + array, + arrayDimension, + arrayValue, + arrayNonNullValue, + -- ** Composite + CompositeDecoder, + composite, + compositeValue, + compositeNonNullValue, + -- ** HStore + hstore, + -- ** + enum, +) +where + +import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure) +import BinaryParser +import qualified PostgreSQL.Binary.Data as Data +import qualified PostgreSQL.Binary.Integral as Integral +import qualified PostgreSQL.Binary.Interval as Interval +import qualified PostgreSQL.Binary.Numeric as Numeric +import qualified PostgreSQL.Binary.Time as Time +import qualified Data.Vector as Vector +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Lazy.Encoding as LazyText +import qualified Data.UUID as UUID +import qualified Data.Aeson as Aeson + + +type Decoder = + BinaryParser + + +-- * Helpers +------------------------- + +-- | +-- Any int number of a limited byte-size. +{-# INLINE intOfSize #-} +intOfSize :: (Integral a, Bits a) => Int -> Decoder a +intOfSize x = + fmap Integral.pack (bytesOfSize x) + +{-# INLINABLE onContent #-} +onContent :: Decoder a -> Decoder ( Maybe a ) +onContent decoder = + intOfSize 4 >>= \case + (-1) -> pure Nothing + n -> fmap Just (sized n decoder) + +{-# INLINABLE content #-} +content :: Decoder (Maybe ByteString) +content = + intOfSize 4 >>= \case + (-1) -> pure Nothing + n -> fmap Just (bytesOfSize n) + +{-# INLINE nonNull #-} +nonNull :: Maybe a -> Decoder a +nonNull = + maybe (failure "Unexpected NULL") return + + +-- * Primitive +------------------------- + +{-# INLINE int #-} +int :: (Integral a, Bits a) => Decoder a +int = + fmap Integral.pack remainders + +float4 :: Decoder Float +float4 = + unsafeCoerce (int :: Decoder Int32) + +float8 :: Decoder Double +float8 = + unsafeCoerce (int :: Decoder Int64) + +{-# INLINE bool #-} +bool :: Decoder Bool +bool = + fmap (== 1) byte + +{-# NOINLINE numeric #-} +numeric :: Decoder Scientific +numeric = + do + componentsAmount <- intOfSize 2 + pointIndex <- intOfSize 2 + signCode <- intOfSize 2 + unitOfSize 2 + components <- Vector.replicateM componentsAmount (intOfSize 2) + either failure return (Numeric.scientific pointIndex signCode components) + +{-# INLINABLE uuid #-} +uuid :: Decoder UUID +uuid = + UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 + +{-# INLINABLE json #-} +json :: Decoder Aeson.Value +json = + bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict' + + +-- ** Textual +------------------------- + +-- | +-- A UTF-8-decoded char. +{-# INLINABLE char #-} +char :: Decoder Char +char = + fmap Text.uncons text_strict >>= \case + Just (c, "") -> return c + Nothing -> failure "Empty input" + _ -> failure "Consumed too much" + +-- | +-- Any of the variable-length character types: +-- BPCHAR, VARCHAR, NAME and TEXT. +{-# INLINABLE text_strict #-} +text_strict :: Decoder Text +text_strict = + remainders >>= either (failure . exception) return . Text.decodeUtf8' + where + exception = + \case + Text.DecodeError message byte -> fromString message + _ -> $bug "Unexpected unicode exception" + +-- | +-- Any of the variable-length character types: +-- BPCHAR, VARCHAR, NAME and TEXT. +{-# INLINABLE text_lazy #-} +text_lazy :: Decoder LazyText +text_lazy = + bytea_lazy >>= either (failure . exception) return . LazyText.decodeUtf8' + where + exception = + \case + Text.DecodeError message byte -> fromString message + _ -> $bug "Unexpected unicode exception" + +-- | +-- BYTEA or any other type in its undecoded form. +{-# INLINE bytea_strict #-} +bytea_strict :: Decoder ByteString +bytea_strict = + remainders + +-- | +-- BYTEA or any other type in its undecoded form. +{-# INLINE bytea_lazy #-} +bytea_lazy :: Decoder LazyByteString +bytea_lazy = + fmap LazyByteString.fromStrict remainders + + +-- * Date and Time +------------------------- + +-- | +-- @DATE@ values decoding. +date :: Decoder Day +date = + fmap (Time.postgresJulianToDay . fromIntegral) (int :: Decoder Int32) + +-- | +-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled. +time_int :: Decoder TimeOfDay +time_int = + fmap Time.microsToTimeOfDay int + +-- | +-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled. +time_float :: Decoder TimeOfDay +time_float = + fmap Time.secsToTimeOfDay float8 + +-- | +-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled. +timetz_int :: Decoder (TimeOfDay, TimeZone) +timetz_int = + (,) <$> sized 8 time_int <*> tz + +-- | +-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timetz_float :: Decoder (TimeOfDay, TimeZone) +timetz_float = + (,) <$> sized 8 time_float <*> tz + +{-# INLINE tz #-} +tz :: Decoder TimeZone +tz = + fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Decoder Int32) + +-- | +-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. +timestamp_int :: Decoder LocalTime +timestamp_int = + fmap Time.microsToLocalTime int + +-- | +-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timestamp_float :: Decoder LocalTime +timestamp_float = + fmap Time.secsToLocalTime float8 + +-- | +-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. +timestamptz_int :: Decoder UTCTime +timestamptz_int = + fmap Time.microsToUTC int + +-- | +-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timestamptz_float :: Decoder UTCTime +timestamptz_float = + fmap Time.secsToUTC float8 + +-- | +-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled. +interval_int :: Decoder DiffTime +interval_int = + do + u <- sized 8 int + d <- sized 4 int + m <- int + return $ Interval.toDiffTime $ Interval.Interval u d m + +-- | +-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled. +interval_float :: Decoder DiffTime +interval_float = + do + u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8) + d <- sized 4 int + m <- int + return $ Interval.toDiffTime $ Interval.Interval u d m + + +-- * Exotic +------------------------- + +-- | +-- A lower-level array data parser, +-- which aggregates the intermediate data representation as per the Postgres format. +-- +-- Only use this if 'array' doesn't fit your case. +{-# INLINABLE arrayRep #-} +arrayRep :: Decoder Data.Array +arrayRep = + do + dimensionsAmount <- intOfSize 4 + nullsValue <- nulls + oid <- intOfSize 4 + dimensions <- Vector.replicateM dimensionsAmount dimension + let valuesAmount = (Vector.product . Vector.map fst) dimensions + values <- Vector.replicateM (fromIntegral valuesAmount) content + return (dimensions, values, nullsValue, oid) + where + dimension = + (,) <$> intOfSize 4 <*> intOfSize 4 + nulls = + intOfSize 4 >>= \(x :: Word32) -> case x of + 0 -> return False + 1 -> return True + w -> failure $ "Invalid value: " <> (fromString . show) w + +{-# INLINABLE compositeRep #-} +compositeRep :: Decoder Data.Composite +compositeRep = + do + componentsAmount <- intOfSize 4 + Vector.replicateM componentsAmount component + where + component = + (,) <$> intOfSize 4 <*> content + +-- | +-- A function for generic in place parsing of an HStore value. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines how to produce the final datastructure from the rows. +-- +-- * A decoder for keys. +-- +-- * A decoder for values. +-- +-- Here's how you can use it to produce a parser to list: +-- +-- @ +-- hstoreAsList :: Decoder [ ( Text , Maybe Text ) ] +-- hstoreAsList = +-- hstore replicateM text text +-- @ +-- +{-# INLINABLE hstore #-} +hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Decoder k -> Decoder v -> Decoder r +hstore replicateM keyContent valueContent = + do + componentsAmount <- intOfSize 4 + replicateM componentsAmount component + where + component = + (,) <$> key <*> value + where + key = + onContent keyContent >>= nonNull + value = + onContent valueContent + +{-# INLINABLE hstoreRep #-} +hstoreRep :: Decoder Data.HStore +hstoreRep = + do + componentsAmount <- intOfSize 4 + Vector.replicateM componentsAmount component + where + component = + (,) <$> key <*> content + where + key = + intOfSize 4 >>= bytesOfSize + + +-- * Composite +------------------------- + +newtype CompositeDecoder a = + CompositeDecoder ( Decoder a ) + deriving ( Functor , Applicative , Monad ) + +-- | +-- Unlift a 'CompositeDecoder' to a value 'Decoder'. +{-# INLINE composite #-} +composite :: CompositeDecoder a -> Decoder a +composite (CompositeDecoder decoder) = + unitOfSize 4 *> decoder + +-- | +-- Lift a value 'Decoder' into 'CompositeDecoder'. +{-# INLINE compositeValue #-} +compositeValue :: Decoder a -> CompositeDecoder ( Maybe a ) +compositeValue = + CompositeDecoder . onContent + +-- | +-- Lift a non-nullable value 'Decoder' into 'CompositeDecoder'. +{-# INLINE compositeNonNullValue #-} +compositeNonNullValue :: Decoder a -> CompositeDecoder a +compositeNonNullValue = + CompositeDecoder . join . fmap (maybe (failure "Unexpected NULL") return) . onContent + + +-- * Array +------------------------- + +-- | +-- An efficient generic array decoder, +-- which constructs the result value in place while parsing. +-- +-- Here's how you can use it to produce a specific array value decoder: +-- +-- @ +-- x :: Decoder [ [ Text ] ] +-- x = +-- array (arrayDimension replicateM (fmap catMaybes (arrayDimension replicateM (arrayValue text)))) +-- @ +-- +newtype ArrayDecoder a = + ArrayDecoder ( [ Word32 ] -> Decoder a ) + deriving ( Functor ) + +-- | +-- Unlift an 'ArrayDecoder' to a value 'Decoder'. +{-# INLINE array #-} +array :: ArrayDecoder a -> Decoder a +array (ArrayDecoder decoder) = + do + dimensionsAmount <- intOfSize 4 + unitOfSize (4 + 4) + dimensionSizes <- replicateM dimensionsAmount dimensionSize + decoder dimensionSizes + where + dimensionSize = + intOfSize 4 <* unitOfSize 4 + +-- | +-- A function for parsing a dimension of an array. +-- Provides support for multi-dimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines the output value. +-- +-- * A decoder of its components, which can be either another 'arrayDimension' or 'arrayValue'. +-- +{-# INLINE arrayDimension #-} +arrayDimension :: ( forall m. Monad m => Int -> m a -> m b ) -> ArrayDecoder a -> ArrayDecoder b +arrayDimension replicateM (ArrayDecoder component) = + ArrayDecoder $ \case + head : tail -> replicateM (fromIntegral head) (component tail) + _ -> failure "A missing dimension length" + +-- | +-- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of nullable leaf values. +{-# INLINE arrayValue #-} +arrayValue :: Decoder a -> ArrayDecoder ( Maybe a ) +arrayValue = + ArrayDecoder . const . onContent + +-- | +-- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of non-nullable leaf values. +{-# INLINE arrayNonNullValue #-} +arrayNonNullValue :: Decoder a -> ArrayDecoder a +arrayNonNullValue = + ArrayDecoder . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent + + +-- * Enum +------------------------- + +-- | +-- Given a partial mapping from text to value, +-- produces a decoder of that value. +{-# INLINE enum #-} +enum :: (Text -> Maybe a) -> Decoder a +enum mapping = + text_strict >>= onText + where + onText text = + maybe onNothing onJust (mapping text) + where + onNothing = + failure ("No mapping for text \"" <> text <> "\"") + onJust = + pure diff --git a/library/PostgreSQL/Binary/Encoder.hs b/library/PostgreSQL/Binary/Encoder.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Encoder.hs @@ -0,0 +1,502 @@ +module PostgreSQL.Binary.Encoder +( + run, + -- * Value encoder + Encoder, + int2_int16, + int2_word16, + int4_int32, + int4_word32, + int8_int64, + int8_word64, + float4, + float8, + composite, + bool, + numeric, + uuid, + json, + char, + text_strict, + text_lazy, + bytea_strict, + bytea_lazy, + date, + time_int, + time_float, + timetz_int, + timetz_float, + timestamp_int, + timestamp_float, + timestamptz_int, + timestamptz_float, + interval_int, + interval_float, + hstore, + hstoreRep, + array, + -- * Array encoder + ArrayEncoder, + arrayValue, + arrayNullableValue, + arrayDimension, + arrayRep, + -- * Enum + enum, +) +where + +import PostgreSQL.Binary.Prelude hiding (take, bool, maybe) +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Encoding as LazyText +import qualified Data.Vector as Vector +import qualified Data.Scientific as Scientific +import qualified Data.Aeson as Aeson +import qualified Data.UUID as UUID +import qualified PostgreSQL.Binary.Data as Data +import qualified PostgreSQL.Binary.Integral as Integral +import qualified PostgreSQL.Binary.Numeric as Numeric +import qualified PostgreSQL.Binary.Time as Time +import qualified PostgreSQL.Binary.Interval as Interval +import qualified PostgreSQL.Binary.BuilderPrim as BuilderPrim +import qualified Control.Foldl as Foldl + + +type Encoder a = + a -> Builder + +{-# INLINE run #-} +run :: Encoder a -> a -> ByteString +run encoder = + LazyByteString.toStrict . Builder.toLazyByteString . encoder + +{-# INLINE tuple2 #-} +tuple2 :: Encoder a -> Encoder b -> Encoder (a, b) +tuple2 e1 e2 = + \(v1, v2) -> e1 v1 <> e2 v2 + +{-# INLINE tuple3 #-} +tuple3 :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c) +tuple3 e1 e2 e3 = + \(v1, v2, v3) -> e1 v1 <> e2 v2 <> e3 v3 + +{-# INLINE tuple4 #-} +tuple4 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder (a, b, c, d) +tuple4 e1 e2 e3 e4 = + \(v1, v2, v3, v4) -> e1 v1 <> e2 v2 <> e3 v3 <> e4 v4 + +{-# INLINE premap #-} +premap :: (a -> b) -> Encoder b -> Encoder a +premap f e = + e . f + +{-# INLINE int2_int16 #-} +int2_int16 :: Encoder Int16 +int2_int16 = + Builder.int16BE + +{-# INLINE int2_word16 #-} +int2_word16 :: Encoder Word16 +int2_word16 = + Builder.word16BE + +{-# INLINE int4_int32 #-} +int4_int32 :: Encoder Int32 +int4_int32 = + Builder.int32BE + +{-# INLINE int4_word32 #-} +int4_word32 :: Encoder Word32 +int4_word32 = + Builder.word32BE + +{-# INLINE int4_int #-} +int4_int :: Encoder Int +int4_int = + int4_int32 . fromIntegral + +{-# INLINE int8_int64 #-} +int8_int64 :: Encoder Int64 +int8_int64 = + Builder.int64BE + +{-# INLINE int8_word64 #-} +int8_word64 :: Encoder Word64 +int8_word64 = + Builder.word64BE + +{-# INLINE float4 #-} +float4 :: Encoder Float +float4 = + int4_int32 . unsafeCoerce + +{-# INLINE float8 #-} +float8 :: Encoder Double +float8 = + int8_int64 . unsafeCoerce + +{-# INLINE null4 #-} +null4 :: ByteStringBuilder +null4 = + Builder.string7 "\255\255\255\255" + +{-# INLINABLE composite #-} +composite :: Encoder Data.Composite +composite vector = + int4_int (Vector.length vector) <> + foldMap component vector + where + component (oid, theContent) = + int4_word32 oid <> content theContent + +{-# INLINABLE content #-} +content :: Encoder Data.Content +content = + \case + Nothing -> + null4 + Just content -> + int4_int (ByteString.length content) <> + Builder.byteString content + +{-# INLINABLE maybe #-} +maybe :: Encoder a -> Encoder (Maybe a) +maybe encoder = + \case + Nothing -> + null4 + Just value -> + run encoder value & \bytes -> int4_int (ByteString.length bytes) <> Builder.byteString bytes + +{-# INLINE bool #-} +bool :: Encoder Bool +bool = + \case + True -> Builder.word8 1 + False -> Builder.word8 0 + +{-# INLINABLE numeric #-} +numeric :: Encoder Scientific +numeric x = + int2_int16 (fromIntegral componentsAmount) <> + int2_int16 (fromIntegral pointIndex) <> + int2_word16 signCode <> + int2_int16 (fromIntegral trimmedExponent) <> + foldMap int2_int16 components + where + componentsAmount = + length components + coefficient = + Scientific.coefficient x + exponent = + Scientific.base10Exponent x + components = + Numeric.extractComponents tunedCoefficient + pointIndex = + componentsAmount + (tunedExponent `div` 4) - 1 + (tunedCoefficient, tunedExponent) = + case mod exponent 4 of + 0 -> (coefficient, exponent) + x -> (coefficient * 10 ^ x, exponent - x) + trimmedExponent = + if tunedExponent >= 0 + then 0 + else negate tunedExponent + signCode = + if coefficient < 0 + then Numeric.negSignCode + else Numeric.posSignCode + +{-# INLINABLE uuid #-} +uuid :: Encoder UUID +uuid = + premap UUID.toWords (tuple4 int4_word32 int4_word32 int4_word32 int4_word32) + +{-# INLINABLE json #-} +json :: Encoder Aeson.Value +json = + Aeson.fromEncoding . Aeson.toEncoding + + +-- * Text +------------------------- + +-- | +-- A UTF-8-encoded char. +-- +-- Note that since it's UTF-8-encoded +-- not the \"char\" but the \"text\" OID should be used with it. +{-# INLINABLE char #-} +char :: Encoder Char +char = + Builder.charUtf8 + +{-# INLINABLE text_strict #-} +text_strict :: Encoder Text +text_strict = + Text.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim + +{-# INLINABLE text_lazy #-} +text_lazy :: Encoder LazyText.Text +text_lazy = + LazyText.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim + +{-# INLINABLE bytea_strict #-} +bytea_strict :: Encoder ByteString +bytea_strict = + Builder.byteString + +{-# INLINABLE bytea_lazy #-} +bytea_lazy :: Encoder LazyByteString.ByteString +bytea_lazy = + Builder.lazyByteString + +-- * Date and Time +------------------------- + +{-# INLINABLE date #-} +date :: Encoder Day +date = + int4_int32 . fromIntegral . Time.dayToPostgresJulian + +{-# INLINABLE time_int #-} +time_int :: Encoder TimeOfDay +time_int (TimeOfDay h m s) = + let + p = unsafeCoerce s :: Integer + u = p `div` (10^6) + in int8_int64 (fromIntegral u + 10^6 * 60 * (fromIntegral m + 60 * fromIntegral h)) + +{-# INLINABLE time_float #-} +time_float :: Encoder TimeOfDay +time_float (TimeOfDay h m s) = + let + p = unsafeCoerce s :: Integer + u = p `div` (10^6) + in float8 (fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h))) + +{-# INLINABLE timetz_int #-} +timetz_int :: Encoder (TimeOfDay, TimeZone) +timetz_int (timeX, tzX) = + time_int timeX <> tz tzX + +{-# INLINABLE timetz_float #-} +timetz_float :: Encoder (TimeOfDay, TimeZone) +timetz_float (timeX, tzX) = + time_float timeX <> tz tzX + +{-# INLINE tz #-} +tz :: Encoder TimeZone +tz = + int4_int . (*60) . negate . timeZoneMinutes + +{-# INLINABLE timestamp_int #-} +timestamp_int :: Encoder LocalTime +timestamp_int = + int8_int64 . Time.localTimeToMicros + +{-# INLINABLE timestamp_float #-} +timestamp_float :: Encoder LocalTime +timestamp_float = + float8 . Time.localTimeToSecs + +{-# INLINABLE timestamptz_int #-} +timestamptz_int :: Encoder UTCTime +timestamptz_int = + int8_int64 . Time.utcToMicros + +{-# INLINABLE timestamptz_float #-} +timestamptz_float :: Encoder UTCTime +timestamptz_float = + float8 . Time.utcToSecs + +{-# INLINABLE interval_int #-} +interval_int :: Encoder DiffTime +interval_int x = + Builder.int64BE u <> + Builder.int32BE d <> + Builder.int32BE m + where + Interval.Interval u d m = + fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $ + Interval.fromDiffTime x + +{-# INLINABLE interval_float #-} +interval_float :: Encoder DiffTime +interval_float x = + Builder.doubleBE s <> + Builder.int32BE d <> + Builder.int32BE m + where + Interval.Interval u d m = + fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $ + Interval.fromDiffTime x + s = + fromIntegral u / (10^6) + + +-- * Array +------------------------- + +newtype ArrayEncoder a = + ArrayEncoder (a -> (Builder, [Int32], Bool)) + +{-# INLINABLE array #-} +array :: Word32 -> ArrayEncoder a -> Encoder a +array oid (ArrayEncoder encoder) = + \value -> + let + (valuesBuilder, dimensions, nulls) = + encoder value + (dimensionsAmount, dimensionsBuilder) = + let + step (amount, builder) dimension = + (succ amount, builder <> Builder.int32BE dimension <> Builder.word32BE 1) + init = + (0, mempty) + in + foldl' step init dimensions + nullsBuilder = + Builder.word32BE (if nulls then 1 else 0) + in + Builder.word32BE dimensionsAmount <> nullsBuilder <> Builder.word32BE oid <> dimensionsBuilder <> valuesBuilder + +{-# INLINABLE arrayValue #-} +arrayValue :: Encoder a -> ArrayEncoder a +arrayValue encoder = + ArrayEncoder $ \value -> + let + bytes = + run encoder value + builder = + Builder.word32BE (fromIntegral (ByteString.length bytes)) <> + Builder.byteString bytes + in + (builder, [], False) + +{-# INLINABLE arrayNullableValue #-} +arrayNullableValue :: Encoder a -> ArrayEncoder (Maybe a) +arrayNullableValue encoder = + ArrayEncoder $ \case + Nothing -> + (int4_int32 (-1), [], True) + Just value -> + let + bytes = + run encoder value + builder = + Builder.word32BE (fromIntegral (ByteString.length bytes)) <> + Builder.byteString bytes + in + (builder, [], False) + +{-# INLINABLE arrayDimension #-} +arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> ArrayEncoder b -> ArrayEncoder c +arrayDimension foldl (ArrayEncoder encoder) = + ArrayEncoder $ \value -> + let + step (builder, _, length, nulls) value = + let + (valueBuilder, valueDimensions, valueNulls) = encoder value + in + (builder <> valueBuilder, valueDimensions, succ length, nulls || valueNulls) + init = + (mempty, [], 0, False) + (foldedBuilder, foldedDimensions, foldedLength, foldedNulls) = + foldl step init value + resultDimensions = + foldedLength : foldedDimensions + in + (foldedBuilder, resultDimensions, foldedNulls) + + +-- * Array rep +------------------------- + +{-# INLINABLE arrayRep #-} +arrayRep :: Encoder Data.Array +arrayRep (dimensionsV, valuesV, nullsV, oidV) = + dimensionsLength <> nulls <> oid <> dimensions <> values + where + dimensionsLength = + int4_word32 $ fromIntegral $ length dimensionsV + nulls = + int4_word32 $ if nullsV then 1 else 0 + oid = + int4_word32 oidV + dimensions = + foldMap dimension dimensionsV + values = + foldMap value valuesV + dimension (w, l) = + int4_word32 w <> int4_word32 l + value = + \case + Nothing -> int4_int32 (-1) + Just b -> int4_int32 (fromIntegral (ByteString.length b)) <> Builder.byteString b + + +-- * HStore +------------------------- + +-- | +-- A polymorphic in-place @HSTORE@ encoder. +-- +-- Accepts: +-- +-- * An implementation of the @foldl@ function +-- (e.g., @Data.Foldable.'foldl''@), +-- which determines the input value. +-- +-- Here's how you can use it to produce a specific encoder: +-- +-- @ +-- hashMapHStore :: Encoder (Data.HashMap.Strict.HashMap Text (Maybe Text)) +-- hashMapHStore = +-- hstore foldl' +-- @ +-- +{-# INLINABLE hstore #-} +hstore :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> Encoder b +hstore foldl = + fold & \(Foldl.Fold step init fin) -> fin . foldl step init + where + fold = + (<>) <$> componentsAmount <*> components + where + componentsAmount = + fmap int4_int Foldl.length + components = + Foldl.foldMap componentBuilder id + where + componentBuilder (key, value) = + text_strict key <> maybe text_strict value + +{-# INLINABLE hstoreRep #-} +hstoreRep :: Encoder Data.HStore +hstoreRep vector = + int4_int32 (fromIntegral (Vector.length vector)) <> + foldMap component vector + where + component (key, value) = + Builder.byteString key <> content value + + +-- * Enum +------------------------- + +-- | +-- Given a function, +-- which maps the value into the textual enum label from the DB side, +-- produces an encoder of that value +-- +{-# INLINE enum #-} +enum :: (a -> Text) -> Encoder a +enum asText = + text_strict . asText diff --git a/library/PostgreSQL/Binary/Integral.hs b/library/PostgreSQL/Binary/Integral.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Integral.hs @@ -0,0 +1,20 @@ +-- | +-- Utils for dealing with integer numbers. +module PostgreSQL.Binary.Integral where + +import PostgreSQL.Binary.Prelude +import qualified Data.ByteString as B + + +{-# INLINABLE pack #-} +pack :: (Bits a, Num a) => B.ByteString -> a +pack = + B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0 + +{-# INLINE unpackBySize #-} +unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString +unpackBySize n x = + B.pack $ map f $ reverse [0..n - 1] + where + f s = + fromIntegral $ shiftR x (8 * s) diff --git a/library/PostgreSQL/Binary/Interval.hs b/library/PostgreSQL/Binary/Interval.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Interval.hs @@ -0,0 +1,43 @@ +module PostgreSQL.Binary.Interval where + +import PostgreSQL.Binary.Prelude hiding (months) +import qualified PostgreSQL.Binary.Time as Time + + +data Interval = + Interval { + micros :: Int64, + days :: Int32, + months :: Int32 + } + deriving (Show, Eq) + + +-- | +-- Oddly enough despite a claim of support of up to 178000000 years in +-- +-- in practice it starts behaving unpredictably after a smaller limit. +maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros +minDiffTime :: DiffTime = negate maxDiffTime + +fromDiffTime :: DiffTime -> Maybe Interval +fromDiffTime x = + if x > maxDiffTime || x < minDiffTime + then Nothing + else Just $ fromPicosUnsafe (unsafeCoerce x) + +fromPicosUnsafe :: Integer -> Interval +fromPicosUnsafe = + evalState $ do + modify $ flip div (10^6) + u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) + d <- state $ swap . flip divMod (31) + m <- get + return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m) + +toDiffTime :: Interval -> DiffTime +toDiffTime x = + picosecondsToDiffTime $ + (10 ^ 6) * + (fromIntegral (micros x) + + 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))) diff --git a/library/PostgreSQL/Binary/Numeric.hs b/library/PostgreSQL/Binary/Numeric.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Numeric.hs @@ -0,0 +1,77 @@ +module PostgreSQL.Binary.Numeric where + +import PostgreSQL.Binary.Prelude +import qualified Data.Vector as Vector +import qualified Data.Scientific as Scientific + + +{-# INLINE posSignCode #-} +posSignCode :: Word16 +posSignCode = 0x0000 + +{-# INLINE negSignCode #-} +negSignCode :: Word16 +negSignCode = 0x4000 + +{-# INLINE nanSignCode #-} +nanSignCode :: Word16 +nanSignCode = 0xC000 + +{-# INLINE extractComponents #-} +extractComponents :: Integral a => a -> [Int16] +extractComponents = + (reverse .) . (. abs) . unfoldr $ \case + 0 -> Nothing + x -> case divMod x 10000 of + (d, m) -> Just (fromIntegral m, d) + +{-# INLINE mergeComponents #-} +mergeComponents :: Integral a => Vector a -> Integer +mergeComponents = + Vector.foldl' (\l r -> l * 10000 + fromIntegral r) 0 + +{-# INLINE mergeDigits #-} +mergeDigits :: Integral a => Vector a -> a +mergeDigits = + Vector.foldl' (\l r -> l * 10 + r) 0 + +-- | +-- Unpack a component into digits. +{-# INLINE componentDigits #-} +componentDigits :: Int16 -> [Int16] +componentDigits = + evalState $ do + a <- state (flip divMod 1000) + b <- state (flip divMod 100) + c <- state (flip divMod 10) + d <- get + return $ [a, b, c, d] + +{-# INLINABLE componentsReplicateM #-} +componentsReplicateM :: (Integral a, Applicative m) => Int -> m a -> m a +componentsReplicateM amount component = + foldl' folder (pure 0) (replicate amount component) + where + folder acc component = + liftA2 (+) (fmap (*10000) acc) component + +{-# INLINE signer #-} +signer :: Integral a => Word16 -> Either Text (a -> a) +signer = + \case + 0x0000 -> return id + 0x4000 -> return negate + 0xC000 -> Left "NAN sign" + signCode -> Left ("Unexpected sign code: " <> (fromString . show) signCode) + +{-# INLINE scientific #-} +scientific :: Int16 -> Word16 -> Vector Word16 -> Either Text Scientific +scientific pointIndex signCode components = + do + theSigner <- signer signCode + return (Scientific.scientific (c theSigner) e) + where + c signer = + signer (mergeComponents components) + e = + (fromIntegral pointIndex + 1 - Vector.length components) * 4 diff --git a/library/PostgreSQL/Binary/Prelude.hs b/library/PostgreSQL/Binary/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Prelude.hs @@ -0,0 +1,94 @@ +module PostgreSQL.Binary.Prelude +( + module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + bug, + bottom, + mapLeft, + joinMap, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, Data, fail) + +-- transformers +------------------------- +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 +import Data.Functor.Identity as Exports + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- vector +------------------------- +import Data.Vector as Exports (Vector) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +-- uuid +------------------------- +import Data.UUID as Exports (UUID) + +-- time +------------------------- +import Data.Time as Exports + +-- placeholders +------------------------- +import Development.Placeholders as Exports + +-- loch-th +------------------------- +import Debug.Trace.LocationTH as Exports + +-- custom +------------------------- +import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Builder +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Debug.Trace.LocationTH + + +type LazyByteString = + Data.ByteString.Lazy.ByteString + +type ByteStringBuilder = + Data.ByteString.Builder.Builder + +type LazyText = + Data.Text.Lazy.Text + +type TextBuilder = + Data.Text.Lazy.Builder.Builder + + +bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] + where + msg = "A \"postgresql-binary\" package bug: " :: String + +bottom = [e| $bug "Bottom evaluated" |] + +{-# INLINE mapLeft #-} +mapLeft :: (a -> b) -> Either a x -> Either b x +mapLeft f = + either (Left . f) Right + +joinMap :: Monad m => (a -> m b) -> m a -> m b +joinMap f = + join . fmap f diff --git a/library/PostgreSQL/Binary/Time.hs b/library/PostgreSQL/Binary/Time.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Time.hs @@ -0,0 +1,134 @@ +module PostgreSQL.Binary.Time where + +import PostgreSQL.Binary.Prelude hiding (second) +import Data.Time.Calendar.Julian + + +{-# INLINABLE dayToPostgresJulian #-} +dayToPostgresJulian :: Day -> Integer +dayToPostgresJulian = + (+ (2400001 - 2451545)) . toModifiedJulianDay + +{-# INLINABLE postgresJulianToDay #-} +postgresJulianToDay :: Integral a => a -> Day +postgresJulianToDay = + ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) + +{-# INLINABLE microsToTimeOfDay #-} +microsToTimeOfDay :: Int64 -> TimeOfDay +microsToTimeOfDay = + evalState $ do + h <- state $ flip divMod $ 10 ^ 6 * 60 * 60 + m <- state $ flip divMod $ 10 ^ 6 * 60 + u <- get + return $ + TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) + +{-# INLINABLE microsToUTC #-} +microsToUTC :: Int64 -> UTCTime +microsToUTC = + evalState $ do + 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 + return $ + 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 +-- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html +-- Postgres uses Julian dates internally +------------------------- + +yearMicros :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational) +dayMicros :: Int64 = 24 * hourMicros +hourMicros :: Int64 = 60 * minuteMicros +minuteMicros :: Int64 = 60 * secondMicros +secondMicros :: Int64 = 10 ^ 6 + diff --git a/library/PostgreSQLBinary/Array.hs b/library/PostgreSQLBinary/Array.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Array.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | --- An intermediate array representation --- and utilities for its (de)composition. -module PostgreSQLBinary.Array where - -import PostgreSQLBinary.Prelude hiding (Data) - - --- | --- A representation of a data serializable to the PostgreSQL array binary format. --- --- Consists of a list of dimensions, a list of encoded elements, --- a flag specifying, whether it contains any nulls, and an oid. -type Data = ([Dimension], [Value], Bool, Word32) - --- | --- A width and a lower bound. --- --- Currently the lower bound is only allowed to have a value of @1@. -type Dimension = (Word32, Word32) - --- | --- An encoded value. 'Nothing' if it represents a @NULL@. -type Value = Maybe ByteString - --- | --- Access a value of data, if the data represents a single value. -asSingleton :: Data -> Maybe Value -asSingleton (dimensions, elements, nulls, oid) = - if null dimensions - then case elements of - [x] -> return x - l -> $bug $ "Unexpected amount of elements: " <> show l - else mzero - --- | --- Construct from a non-empty list, --- taking the shared parameters from the first element. -fromListUnsafe :: [Data] -> Data -fromListUnsafe list = - case list of - (dimensions, values, nulls, oid) : tail -> - ((fromIntegral $ length list, 1) : dimensions, values <> foldMap valuesOf tail, nulls, oid) - where - valuesOf (_, x, _, _) = x - _ -> - error "Empty list" - -fromSingleton :: Value -> Bool -> Word32 -> Data -fromSingleton value nullable oid = - ([], [value], nullable, oid) - --- | --- Get a list of elements. -elements :: Data -> [Data] -elements (dimensions, values, nulls, oid) = - do - subvalues <- slice values - return (subdimensions, subvalues, nulls, oid) - where - ((width, lowerBound), subdimensions) = - case dimensions of - h : t -> (h, t) - _ -> ((0, 1), []) - chunkSize = - if null subdimensions - then 1 - else product $ map dimensionWidth $ subdimensions - where - dimensionWidth (x, _) = fromIntegral x - slice = - foldr (\f g l -> case f l of (a, b) -> a : g b) (const mzero) $ - replicate (fromIntegral width) (splitAt chunkSize) diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Decoder.hs +++ /dev/null @@ -1,175 +0,0 @@ -module PostgreSQLBinary.Decoder where - -import PostgreSQLBinary.Prelude hiding (bool) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import qualified Data.Scientific as Scientific -import qualified Data.UUID as UUID -import qualified PostgreSQLBinary.Decoder.Zepto as Zepto -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Time as Time -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Numeric as Numeric -import qualified PostgreSQLBinary.Interval as Interval - - --- | --- A function for decoding a byte string into a value. -type D a = ByteString -> Either Text a - - --- * Numbers -------------------------- - --- | --- Any of PostgreSQL integer types. -{-# INLINABLE int #-} -int :: (Integral a, Bits a) => D a -int = - Right . Integral.pack - -{-# INLINABLE float4 #-} -float4 :: D Float -float4 = - unsafeCoerce (int :: D Word32) - -{-# INLINABLE float8 #-} -float8 :: D Double -float8 = - unsafeCoerce (int :: D Word64) - -{-# INLINABLE numeric #-} -numeric :: D Scientific -numeric = - flip Zepto.run (inline Zepto.numeric) - - --- * Text -------------------------- - --- | --- A UTF-8-encoded char. -{-# INLINABLE char #-} -char :: D Char -char x = - maybe (Left "Empty input") (return . fst) . T.uncons =<< text x - --- | --- Any of the variable-length character types: --- BPCHAR, VARCHAR, NAME and TEXT. -{-# INLINABLE text #-} -text :: D Text -text = - either (Left . fromString . show) Right . TE.decodeUtf8' - -{-# INLINE bytea #-} -bytea :: D ByteString -bytea = - Right - --- * Date and Time -------------------------- - -{-# INLINABLE date #-} -date :: D Day -date = - fmap (Time.postgresJulianToDay . fromIntegral) . (int :: D Int32) - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE time #-} -time :: Bool -> D TimeOfDay -time = - \case - True -> - fmap Time.microsToTimeOfDay . int - False -> - fmap Time.secsToTimeOfDay . float8 - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timetz #-} -timetz :: Bool -> D (TimeOfDay, TimeZone) -timetz integer_datetimes = - \x -> - let (timeX, zoneX) = B.splitAt 8 x - in (,) <$> time integer_datetimes timeX <*> tz zoneX - where - tz = - fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32) - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timestamptz #-} -timestamp :: Bool -> D LocalTime -timestamp = - \case - True -> - fmap Time.microsToLocalTime . int - False -> - fmap Time.secsToLocalTime . float8 - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timestamp #-} -timestamptz :: Bool -> D UTCTime -timestamptz = - \case - True -> - fmap Time.microsToUTC . int - False -> - fmap Time.secsToUTC . float8 - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE interval #-} -interval :: Bool -> D DiffTime -interval integerDatetimes = - evalState $ do - t <- state $ B.splitAt 8 - d <- state $ B.splitAt 4 - m <- get - return $ do - ux <- if integerDatetimes - then int t - else float8 t >>= return . round . (* (10^6)) . toRational - dx <- int d - mx <- int m - return $ Interval.toDiffTime $ Interval.Interval ux dx mx - - --- * Misc -------------------------- - -{-# INLINABLE bool #-} -bool :: D Bool -bool b = - case B.uncons b of - Just (0, _) -> return False - Just (1, _) -> return True - _ -> Left ("Invalid value: " <> (fromString . show) b) - -{-# INLINABLE uuid #-} -uuid :: D UUID -uuid = - evalStateT $ - UUID.fromWords <$> word <*> word <*> word <*> word - where - word = - lift . int =<< state (B.splitAt 4) - - --- | --- Arbitrary array. --- --- Returns an intermediate representation, --- which can then be used to decode into a specific data type. -{-# INLINABLE array #-} -array :: D Array.Data -array = - flip Zepto.run Zepto.array diff --git a/library/PostgreSQLBinary/Decoder/Zepto.hs b/library/PostgreSQLBinary/Decoder/Zepto.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Decoder/Zepto.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | --- Composable Attoparsec parsers. -module PostgreSQLBinary.Decoder.Zepto where - -import PostgreSQLBinary.Prelude hiding (take, bool) -import Data.Attoparsec.Zepto -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Numeric as Numeric -import qualified Data.Scientific as Scientific - - -{-# INLINE run #-} -run :: ByteString -> Parser a -> Either Text a -run input parser = - either (Left . fromString . show) Right $ parse parser input - -{-# INLINE endOfInput #-} -endOfInput :: Parser () -endOfInput = - atEnd >>= \case True -> return (); False -> fail "Not an end of input" - -{-# INLINE intOfSize #-} -intOfSize :: (Integral a, Bits a) => Int -> Parser a -intOfSize x = - Integral.pack <$> take x - -{-# INLINABLE array #-} -array :: Parser Array.Data -array = - do - dimensionsAmountV <- intOfSize 4 - nullsV <- nulls - oidV <- intOfSize 4 - dimensionsV <- replicateM dimensionsAmountV dimension - valuesV <- many value - return (dimensionsV, valuesV, nullsV, oidV) - where - dimension = - (,) <$> intOfSize 4 <*> intOfSize 4 - value = - nothing <|> just - where - nothing = - string (Integral.unpack (-1 :: Word32)) *> pure Nothing - just = - Just <$> (take =<< intOfSize 4) - nulls = - (intOfSize 4 :: Parser Word32) >>= \case - 0 -> return False - 1 -> return True - w -> fail $ "Invalid value: " <> show w - -{-# INLINE numeric #-} -numeric :: Parser Scientific -numeric = - do - componentsAmount <- intOfSize 2 - pointIndex :: Int16 <- intOfSize 2 - signCode <- intOfSize 2 - take 2 - components <- replicateM componentsAmount (intOfSize 2) - signer <- - if | signCode == Numeric.negSignCode -> return negate - | signCode == Numeric.posSignCode -> return id - | signCode == Numeric.nanSignCode -> fail "NAN sign" - | otherwise -> fail $ "Unexpected sign value: " <> show signCode - let - c = signer $ fromIntegral $ (Numeric.mergeComponents components :: Word64) - e = (fromIntegral (pointIndex + 1) - length components) * 4 - in return $ Scientific.scientific c e diff --git a/library/PostgreSQLBinary/Encoder.hs b/library/PostgreSQLBinary/Encoder.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Encoder.hs +++ /dev/null @@ -1,174 +0,0 @@ -module PostgreSQLBinary.Encoder where - -import PostgreSQLBinary.Prelude -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import qualified PostgreSQLBinary.Encoder.Builder as Builder -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Time as Time -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Interval as Interval -import qualified PostgreSQLBinary.Numeric as Numeric - - --- | --- A function for rendering a value into a byte string. -type E a = a -> ByteString - - --- * Numbers -------------------------- - -{-# INLINABLE int2 #-} -int2 :: E (Either Int16 Word16) -int2 = - either unpack unpack - where - unpack = Integral.unpackBySize 2 - -{-# INLINABLE int4 #-} -int4 :: E (Either Int32 Word32) -int4 = - either unpack unpack - where - unpack = Integral.unpackBySize 4 - -{-# INLINABLE int8 #-} -int8 :: E (Either Int64 Word64) -int8 = - either unpack unpack - where - unpack = Integral.unpackBySize 8 - -{-# INLINABLE float4 #-} -float4 :: E Float -float4 = - int4 . Right . (unsafeCoerce :: Float -> Word32) - -{-# INLINABLE float8 #-} -float8 :: E Double -float8 = - int8 . Right . (unsafeCoerce :: Double -> Word64) - -{-# INLINABLE numeric #-} -numeric :: E Scientific -numeric = - Builder.run . Builder.numeric - --- * Text -------------------------- - --- | --- A UTF-8-encoded char. --- --- Note that since it's UTF-8-encoded --- not a \"char\" but a \"text\" OID should be used with it. -{-# INLINABLE char #-} -char :: E Char -char = - text . Left . T.singleton - --- | --- Either a strict or a lazy text. -{-# INLINABLE text #-} -text :: E (Either Text TL.Text) -text = - either strict lazy - where - strict = TE.encodeUtf8 . T.filter (/= '\0') - lazy = BL.toStrict . TLE.encodeUtf8 . TL.filter (/= '\0') - --- | --- Either a strict or a lazy bytestring. -{-# INLINABLE bytea #-} -bytea :: E (Either ByteString BL.ByteString) -bytea = - either id BL.toStrict - --- * Date and Time -------------------------- - -{-# INLINABLE date #-} -date :: E Day -date = - Builder.run . Builder.date - --- | --- Encoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE 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 :: 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 :: Bool -> E LocalTime -timestamp = - \case - True -> int8 . Left . Time.localTimeToMicros - False -> float8 . Time.localTimeToSecs - -{-# INLINABLE timestamptz #-} -timestamptz :: Bool -> E UTCTime -timestamptz = - \case - True -> int8 . Left . Time.utcToMicros - False -> float8 . Time.utcToSecs - -{-# INLINABLE interval #-} -interval :: Bool -> E DiffTime -interval integerDatetimes x = - Builder.run $ - (if integerDatetimes then BB.int64BE u else BB.doubleBE s) <> - BB.int32BE d <> - BB.int32BE m - where - Interval.Interval u d m = - fromMaybe (error "Too large DiffTime value for an interval") $ - Interval.fromDiffTime x - s = fromIntegral u / (10^6) - --- * Misc -------------------------- - -{-# INLINABLE bool #-} -bool :: E Bool -bool = - \case - False -> B.singleton 0 - True -> B.singleton 1 - -{-# INLINABLE uuid #-} -uuid :: E UUID -uuid = - Builder.run . Builder.uuid - -{-# INLINABLE array #-} -array :: E Array.Data -array = - Builder.run . Builder.array diff --git a/library/PostgreSQLBinary/Encoder/Builder.hs b/library/PostgreSQLBinary/Encoder/Builder.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Encoder/Builder.hs +++ /dev/null @@ -1,98 +0,0 @@ -module PostgreSQLBinary.Encoder.Builder where - -import PostgreSQLBinary.Prelude hiding (bool) -import Data.ByteString.Lazy.Builder -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Scientific as Scientific -import qualified Data.UUID as UUID -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Time as Time -import qualified PostgreSQLBinary.Numeric as Numeric -import qualified PostgreSQLBinary.Interval as Interval - - -{-# INLINE run #-} -run :: Builder -> B.ByteString -run = - BL.toStrict . toLazyByteString - -{-# INLINE bool #-} -bool :: Bool -> Builder -bool = - \case True -> word8 1; False -> word8 0 - -{-# INLINE array #-} -array :: Array.Data -> Builder -array (dimensionsV, valuesV, nullsV, oidV) = - dimensionsLength <> nulls <> oid <> dimensions <> values - where - dimensionsLength = - word32BE $ fromIntegral $ length dimensionsV - nulls = - word32BE $ if nullsV then 1 else 0 - oid = - word32BE oidV - dimensions = - foldMap dimension dimensionsV - values = - foldMap value valuesV - dimension (w, l) = - word32BE w <> word32BE l - value = - \case - Nothing -> word32BE (-1) - Just b -> word32BE (fromIntegral (B.length b)) <> byteString b - -{-# INLINE date #-} -date :: Day -> Builder -date = - int32BE . fromIntegral . Time.dayToPostgresJulian - -{-# INLINE numeric #-} -numeric :: Scientific -> Builder -numeric x = - int16BE (fromIntegral componentsAmount) <> - int16BE (fromIntegral pointIndex) <> - word16BE signCode <> - int16BE (fromIntegral trimmedExponent) <> - foldMap int16BE components - where - componentsAmount = - length components - coefficient = - Scientific.coefficient x - exponent = - Scientific.base10Exponent x - components = - Numeric.extractComponents tunedCoefficient - pointIndex = - componentsAmount + (tunedExponent `div` 4) - 1 - (tunedCoefficient, tunedExponent) = - case mod exponent 4 of - 0 -> (coefficient, exponent) - x -> (coefficient * 10 ^ x, exponent - x) - trimmedExponent = - if tunedExponent >= 0 - then 0 - else negate tunedExponent - signCode = - if coefficient < 0 - then Numeric.negSignCode - else Numeric.posSignCode - -{-# INLINE uuid #-} -uuid :: UUID -> Builder -uuid = - UUID.toWords >>> \(a, b, c, d) -> - word32BE a <> - word32BE b <> - word32BE c <> - word32BE d - diff --git a/library/PostgreSQLBinary/Integral.hs b/library/PostgreSQLBinary/Integral.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Integral.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | --- Utils for dealing with numbers. -module PostgreSQLBinary.Integral where - -import PostgreSQLBinary.Prelude -import qualified Data.ByteString as B - - -{-# INLINE byteSize #-} -byteSize :: (Bits a) => a -> Int -byteSize = (`div` 8) . bitSize - -{-# INLINE pack #-} -pack :: (Bits a, Num a) => B.ByteString -> a -pack = B.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0 - -{-# INLINE unpack #-} -unpack :: (Bits a, Integral a) => a -> B.ByteString -unpack x = unpackBySize (byteSize x) x - -{-# INLINE unpackBySize #-} -unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString -unpackBySize n x = B.pack $ map f $ reverse [0..n - 1] - where f s = fromIntegral $ shiftR x (8 * s) diff --git a/library/PostgreSQLBinary/Interval.hs b/library/PostgreSQLBinary/Interval.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Interval.hs +++ /dev/null @@ -1,43 +0,0 @@ -module PostgreSQLBinary.Interval where - -import PostgreSQLBinary.Prelude hiding (months) -import qualified PostgreSQLBinary.Time as Time - - -data Interval = - Interval { - micros :: Int64, - days :: Int32, - months :: Int32 - } - deriving (Show, Eq) - - --- | --- Oddly enough despite a claim of support of up to 178000000 years in --- --- in practice it starts behaving unpredictably after a smaller limit. -maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros -minDiffTime :: DiffTime = negate maxDiffTime - -fromDiffTime :: DiffTime -> Maybe Interval -fromDiffTime x = - if x > maxDiffTime || x < minDiffTime - then Nothing - else Just $ fromPicosUnsafe (unsafeCoerce x) - -fromPicosUnsafe :: Integer -> Interval -fromPicosUnsafe = - evalState $ do - modify $ flip div (10^6) - u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) - d <- state $ swap . flip divMod (31) - m <- get - return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m) - -toDiffTime :: Interval -> DiffTime -toDiffTime x = - picosecondsToDiffTime $ - (10 ^ 6) * - (fromIntegral (micros x) + - 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))) diff --git a/library/PostgreSQLBinary/Numeric.hs b/library/PostgreSQLBinary/Numeric.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Numeric.hs +++ /dev/null @@ -1,38 +0,0 @@ -module PostgreSQLBinary.Numeric where - -import PostgreSQLBinary.Prelude - - -posSignCode :: Word16 = 0x0000 -negSignCode :: Word16 = 0x4000 -nanSignCode :: Word16 = 0xC000 - -{-# INLINE extractComponents #-} -extractComponents :: Integral a => a -> [Int16] -extractComponents = - (reverse .) . (. abs) . unfoldr $ \case - 0 -> Nothing - x -> case divMod x 10000 of - (d, m) -> Just (fromIntegral m, d) - -{-# INLINE mergeComponents #-} -mergeComponents :: Integral a => [a] -> a -mergeComponents = - foldl' (\l r -> l * 10000 + r) 0 - -{-# INLINE mergeDigits #-} -mergeDigits :: Integral a => [a] -> a -mergeDigits = - foldl' (\l r -> l * 10 + r) 0 - --- | --- Unpack a component into digits. -{-# INLINE componentDigits #-} -componentDigits :: Int16 -> [Int16] -componentDigits = - evalState $ do - a <- state (`divMod` 1000) - b <- state (`divMod` 100) - c <- state (`divMod` 10) - d <- get - return $ [a, b, c, d] diff --git a/library/PostgreSQLBinary/Prelude.hs b/library/PostgreSQLBinary/Prelude.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Prelude.hs +++ /dev/null @@ -1,65 +0,0 @@ -module PostgreSQLBinary.Prelude -( - module Exports, - LazyByteString, - LazyText, - bug, - bottom, - partial, -) -where - - --- base-prelude -------------------------- -import BasePrelude as Exports - --- transformers -------------------------- -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 -------------------------- -import Data.Text as Exports (Text) - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - --- scientific -------------------------- -import Data.Scientific as Exports (Scientific) - --- uuid -------------------------- -import Data.UUID as Exports (UUID) - --- time -------------------------- -import Data.Time as Exports - --- placeholders -------------------------- -import Development.Placeholders as Exports - --- custom -------------------------- -import qualified Debug.Trace.LocationTH -import qualified Data.Text.Lazy -import qualified Data.ByteString.Lazy - - -type LazyByteString = Data.ByteString.Lazy.ByteString -type LazyText = Data.Text.Lazy.Text - -bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] - where - msg = "A \"postgresql-binary\" package bug: " :: String - -bottom = [e| $bug "Bottom evaluated" |] - -partial :: Alternative f => (a -> Bool) -> a -> f a -partial p x = - if p x then pure x else empty diff --git a/library/PostgreSQLBinary/Time.hs b/library/PostgreSQLBinary/Time.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Time.hs +++ /dev/null @@ -1,134 +0,0 @@ -module PostgreSQLBinary.Time where - -import PostgreSQLBinary.Prelude hiding (second) -import Data.Time.Calendar.Julian - - -{-# INLINABLE dayToPostgresJulian #-} -dayToPostgresJulian :: Day -> Integer -dayToPostgresJulian = - (+ (2400001 - 2451545)) . toModifiedJulianDay - -{-# INLINABLE postgresJulianToDay #-} -postgresJulianToDay :: Int64 -> Day -postgresJulianToDay = - ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) - -{-# INLINABLE microsToTimeOfDay #-} -microsToTimeOfDay :: Int64 -> TimeOfDay -microsToTimeOfDay = - evalState $ do - h <- state $ flip divMod $ 10 ^ 6 * 60 * 60 - m <- state $ flip divMod $ 10 ^ 6 * 60 - u <- get - return $ - TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) - -{-# INLINABLE microsToUTC #-} -microsToUTC :: Int64 -> UTCTime -microsToUTC = - evalState $ do - 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 - return $ - 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 --- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html --- Postgres uses Julian dates internally -------------------------- - -yearMicros :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational) -dayMicros :: Int64 = 24 * hourMicros -hourMicros :: Int64 = 60 * minuteMicros -minuteMicros :: Int64 = 60 * secondMicros -secondMicros :: Int64 = 10 ^ 6 - diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal --- a/postgresql-binary.cabal +++ b/postgresql-binary.cabal @@ -1,14 +1,14 @@ name: postgresql-binary version: - 0.5.2.1 + 0.7.4 synopsis: Encoders and decoders for the PostgreSQL's binary format description: An API for dealing with PostgreSQL's binary data format. . - It can be used to implement high level APIs for Postgres. - E.g., + It can be used to implement performant bindings to Postgres. + E.g., is based on this library. . It supports all Postgres versions starting from 8.3 @@ -53,47 +53,54 @@ default-language: Haskell2010 other-modules: - PostgreSQLBinary.Prelude - PostgreSQLBinary.Encoder.Builder - PostgreSQLBinary.Decoder.Zepto - PostgreSQLBinary.Integral - PostgreSQLBinary.Numeric - PostgreSQLBinary.Time - PostgreSQLBinary.Interval + PostgreSQL.Binary.Prelude + PostgreSQL.Binary.Integral + PostgreSQL.Binary.Interval + PostgreSQL.Binary.Numeric + PostgreSQL.Binary.Time + PostgreSQL.Binary.BuilderPrim exposed-modules: - PostgreSQLBinary.Array - PostgreSQLBinary.Encoder - PostgreSQLBinary.Decoder + PostgreSQL.Binary.Data + PostgreSQL.Binary.Decoder + PostgreSQL.Binary.Encoder build-depends: - -- parsers: - attoparsec >= 0.10 && < 0.14, + -- parsing: + binary-parser >= 0.5 && < 0.6, -- data: + aeson >= 0.10 && < 0.11, uuid == 1.3.*, time >= 1.4 && < 1.6, scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, + bytestring >= 0.10.4 && < 0.11, + text >= 1 && < 2, + vector >= 0.10 && < 0.12, -- errors: loch-th == 0.2.*, placeholders == 0.1.*, -- general: + foldl >= 1.1.1 && < 2, transformers >= 0.3 && < 0.5, - base-prelude >= 0.1.3 && < 0.2 + base-prelude >= 0.1.19 && < 0.2, + base >= 4.6 && < 5 -test-suite tests - type: +-- This test-suite must be executed in a single-thread. +test-suite tasty + type: exitcode-stdio-1.0 - hs-source-dirs: - executables - main-is: - Tests.hs + hs-source-dirs: + tasty + main-is: + Main.hs other-modules: - PostgreSQLBinary.PTI - ghc-options: - -threaded - "-with-rtsopts=-N" - -funbox-strict-fields + Main.TextEncoder + Main.DB + Main.Apx + Main.IO + Main.Gens + Main.PTI + Main.Properties + Main.Prelude default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: @@ -101,28 +108,40 @@ build-depends: -- testing: postgresql-binary, - HTF == 0.12.*, - quickcheck-instances == 0.3.*, - QuickCheck >= 2.7 && < 2.9, - -- database: postgresql-libpq == 0.9.*, + tasty == 0.11.*, + tasty-quickcheck == 0.8.*, + tasty-smallcheck == 0.8.*, + tasty-hunit == 0.9.*, + quickcheck-instances >= 0.3.11 && < 0.4, + QuickCheck >= 2.8.1 && < 2.9, -- data: uuid == 1.3.*, time >= 1.4 && < 1.6, scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, + bytestring >= 0.10.4 && < 0.11, + text >= 1 && < 2, + vector >= 0.10 && < 0.12, + -- errors: + loch-th == 0.2.*, + placeholders == 0.1.*, -- general: - base-prelude >= 0.1.3 && < 0.2 + conversion == 1.*, + conversion-bytestring == 1.*, + conversion-text == 1.*, + either == 4.*, + transformers, + base-prelude, + base -benchmark decoding +benchmark encoding type: exitcode-stdio-1.0 hs-source-dirs: - executables + encoding main-is: - Decoding.hs + Main.hs ghc-options: -O2 -threaded @@ -137,23 +156,23 @@ -- benchmarking: criterion >= 1.0 && < 1.2, -- data: - time >= 1.4 && < 1.6, - scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, + time, + scientific, + text, + bytestring, -- general: deepseq >= 1.3 && < 1.5, mtl-prelude < 3, - base-prelude >= 0.1.3 && < 0.2 + base-prelude -benchmark encoding +benchmark decoding type: exitcode-stdio-1.0 hs-source-dirs: - executables + decoding main-is: - Encoding.hs + Main.hs ghc-options: -O2 -threaded @@ -168,11 +187,11 @@ -- benchmarking: criterion >= 1.0 && < 1.2, -- data: - time >= 1.4 && < 1.6, - scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, + time, + scientific, + text, + bytestring, -- general: deepseq >= 1.3 && < 1.5, mtl-prelude < 3, - base-prelude >= 0.1.3 && < 0.2 + base-prelude diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,214 @@ +module Main where + +import Main.Prelude hiding (assert, isRight, isLeft) +import Control.Monad.IO.Class +import Test.QuickCheck.Instances +import Test.Tasty +import qualified Test.Tasty.HUnit as HUnit +import qualified Test.Tasty.SmallCheck as SmallCheck +import qualified Test.Tasty.QuickCheck as QuickCheck +import qualified Test.QuickCheck as QuickCheck +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified Data.ByteString as ByteString +import qualified Main.DB as DB +import qualified Main.Gens as Gens +import qualified Main.Properties as Properties +import qualified Main.IO as IO +import qualified Main.PTI as PTI +import qualified Main.TextEncoder as TextEncoder +import Main.Apx (Apx(..)) + + +main = + defaultMain (testGroup "" [binary, textual]) + +binary = + testGroup "Binary format" + [ + select "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval" + (bool Decoder.interval_float Decoder.interval_int) + (picosecondsToDiffTime (10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12)))))))) + , + timeRoundtrip "interval" Gens.intervalDiffTime PTI.interval + (bool Encoder.interval_float Encoder.interval_int) + (bool Decoder.interval_float Decoder.interval_int) + , + timeRoundtrip "timestamp" (fmap Apx Gens.auto) PTI.timestamp + ((. unApx) . bool Encoder.timestamp_float Encoder.timestamp_int) + (fmap Apx . bool Decoder.timestamp_float Decoder.timestamp_int) + , + HUnit.testCase "timestamptz offset" $ do + Right (textual, decoded) <- + DB.session $ do + integerDatetimes <- DB.integerDatetimes + let encoder = bool Encoder.timestamptz_float Encoder.timestamptz_int integerDatetimes + decoder = bool Decoder.timestamptz_float Decoder.timestamptz_int integerDatetimes + DB.unit "DROP TABLE IF EXISTS a" [] + DB.unit "CREATE TABLE a (b TIMESTAMPTZ)" [] + DB.unit "set timezone to 'America/Los_Angeles'" [] + let p = (,,) (PTI.oidPQ (PTI.ptiOID PTI.timestamptz)) + (Encoder.run encoder x) + (DB.Binary) + x = read "2011-09-28 00:17:25" + DB.unit "insert into a (b) values ($1)" [Just p] + DB.unit "set timezone to 'Europe/Stockholm'" [] + textual <- DB.oneRow "SELECT * FROM a" [] DB.Text + decoded <- fmap (Decoder.run decoder) (DB.oneRow "SELECT * FROM a" [] DB.Binary) + return (textual, decoded) + HUnit.assertEqual "" ("2011-09-28 02:17:25+02") textual + HUnit.assertEqual "" (Right (read "2011-09-28 00:17:25")) decoded + , + timeRoundtrip "timestamptz" (fmap Apx Gens.auto) PTI.timestamptz + ((. unApx) . bool Encoder.timestamptz_float Encoder.timestamptz_int) + (fmap Apx . bool Decoder.timestamptz_float Decoder.timestamptz_int) + , + timeRoundtrip "timetz" (fmap Apx Gens.timetz) PTI.timetz + ((. unApx) . bool Encoder.timetz_float Encoder.timetz_int) + (fmap Apx . bool Decoder.timetz_float Decoder.timetz_int) + , + timeRoundtrip "time" (fmap Apx Gens.auto) PTI.time + ((. unApx) . bool Encoder.time_float Encoder.time_int) + (fmap Apx . bool Decoder.time_float Decoder.time_int) + , + stdRoundtrip "numeric" Gens.scientific PTI.numeric Encoder.numeric Decoder.numeric + , + select "SELECT -1234560.789 :: numeric" (const Decoder.numeric) (read "-1234560.789") + , + select "SELECT -0.0789 :: numeric" (const Decoder.numeric) (read "-0.0789") + , + select "SELECT 10000 :: numeric" (const Decoder.numeric) (read "10000") + , + stdRoundtrip "float4" Gens.auto PTI.float4 Encoder.float4 Decoder.float4 + , + stdRoundtrip "float8" Gens.auto PTI.float8 Encoder.float8 Decoder.float8 + , + stdRoundtrip "char" Gens.char PTI.text Encoder.char Decoder.char + , + stdRoundtrip "text_strict" Gens.text PTI.text Encoder.text_strict Decoder.text_strict + , + stdRoundtrip "text_lazy" (fmap convert Gens.text) PTI.text Encoder.text_lazy Decoder.text_lazy + , + stdRoundtrip "bytea_strict" Gens.auto PTI.bytea Encoder.bytea_strict Decoder.bytea_strict + , + stdRoundtrip "bytea_lazy" Gens.auto PTI.bytea Encoder.bytea_lazy Decoder.bytea_lazy + , + stdRoundtrip "uuid" Gens.uuid PTI.uuid Encoder.uuid Decoder.uuid + , + stdRoundtrip "int2_int16" Gens.auto PTI.int2 Encoder.int2_int16 Decoder.int + , + stdRoundtrip "int2_word16" Gens.auto PTI.int2 Encoder.int2_word16 Decoder.int + , + stdRoundtrip "int4_int32" Gens.auto PTI.int4 Encoder.int4_int32 Decoder.int + , + stdRoundtrip "int4_word32" Gens.auto PTI.int4 Encoder.int4_word32 Decoder.int + , + stdRoundtrip "int8_int64" Gens.auto PTI.int8 Encoder.int8_int64 Decoder.int + , + stdRoundtrip "int8_word64" Gens.auto PTI.int8 Encoder.int8_word64 Decoder.int + , + stdRoundtrip "bool" Gens.auto PTI.bool Encoder.bool Decoder.bool + , + stdRoundtrip "date" Gens.auto PTI.date Encoder.date Decoder.date + , + let + decoder = + Decoder.array $ + Decoder.arrayDimension replicateM $ + Decoder.arrayDimension replicateM $ + Decoder.arrayNonNullValue $ + Decoder.int + in + select "SELECT ARRAY[ARRAY[1,2],ARRAY[3,4]]" (const decoder) ([[1,2],[3,4]] :: [[Int]]) + , + let + encoder = + Encoder.array (PTI.oidWord32 (PTI.ptiOID PTI.int8)) $ + Encoder.arrayDimension foldl' $ + Encoder.arrayDimension foldl' $ + Encoder.arrayDimension foldl' $ + Encoder.arrayValue $ + Encoder.int8_int64 + decoder = + Decoder.array $ + Decoder.arrayDimension replicateM $ + Decoder.arrayDimension replicateM $ + Decoder.arrayDimension replicateM $ + Decoder.arrayNonNullValue $ + Decoder.int + in + arrayCodec (Gens.array3 Gens.auto) encoder decoder + , + let + pti = + PTI.text + encoder = + Encoder.array (PTI.oidWord32 (PTI.ptiOID pti)) $ + Encoder.arrayDimension foldl' $ + Encoder.arrayDimension foldl' $ + Encoder.arrayDimension foldl' $ + Encoder.arrayValue $ + Encoder.text_strict + decoder = + Decoder.array $ + Decoder.arrayDimension replicateM $ + Decoder.arrayDimension replicateM $ + Decoder.arrayDimension replicateM $ + Decoder.arrayNonNullValue $ + Decoder.text_strict + in + arrayRoundtrip (Gens.array3 Gens.text) pti encoder decoder + ] + +textual = + testGroup "Textual format" $ + [ + test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const Decoder.numeric) + , + test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const Decoder.float4) + , + test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const Decoder.float8) + , + test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const Decoder.uuid) + , + test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const Decoder.int) + , + test "int2_word16" Gens.postgresInt PTI.int2 TextEncoder.int2_word16 (const Decoder.int) + , + test "int4_int32" Gens.auto PTI.int4 TextEncoder.int4_int32 (const Decoder.int) + , + test "int4_word32" Gens.postgresInt PTI.int4 TextEncoder.int4_word32 (const Decoder.int) + , + test "int8_int64" Gens.auto PTI.int8 TextEncoder.int8_int64 (const Decoder.int) + , + test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const Decoder.int) + , + test "bool" Gens.auto PTI.bool TextEncoder.bool (const Decoder.bool) + ] + where + test typeName gen pti encoder decoder = + QuickCheck.testProperty (typeName <> " roundtrip") $ + QuickCheck.forAll gen $ Properties.textRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder + +arrayCodec gen encoder decoder = + QuickCheck.testProperty ("Array codec") $ + QuickCheck.forAll gen $ + \value -> (QuickCheck.===) (Right value) (Decoder.run decoder (Encoder.run encoder value)) + +arrayRoundtrip gen pti encoder decoder = + QuickCheck.testProperty ("Array roundtrip") $ + QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (fromJust (PTI.ptiArrayOID pti))) encoder decoder + +stdRoundtrip typeName gen pti encoder decoder = + QuickCheck.testProperty (typeName <> " roundtrip") $ + QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder + +timeRoundtrip typeName gen pti encoder decoder = + QuickCheck.testProperty (typeName <> " roundtrip") $ + QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder + +select statement decoder value = + HUnit.testCase (show statement) $ + HUnit.assertEqual "" (Right value) $ + unsafePerformIO $ IO.parameterlessStatement statement decoder value + diff --git a/tasty/Main/Apx.hs b/tasty/Main/Apx.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Apx.hs @@ -0,0 +1,52 @@ +module Main.Apx where + +import Main.Prelude + + +-- | +-- A wrapper which provides a type-specific 'Eq' instance +-- with approximate comparison. +newtype Apx a = + Apx { unApx :: a } + deriving (Show) + +instance (Eq (Apx a), Eq (Apx b)) => Eq (Apx (a, b)) where + (==) (Apx (a1, a2)) (Apx (b1, b2)) = + Apx a1 == Apx b1 && + Apx a2 == Apx b2 + +instance Eq (Apx LocalTime) where + (==) (Apx a) (Apx b) = + localTimeRep a == localTimeRep b + +instance Eq (Apx UTCTime) where + (==) (Apx a) (Apx b) = + utcTimeApxRep a == utcTimeApxRep b + +instance Eq (Apx TimeOfDay) where + (==) (Apx a) (Apx b) = + timeOfDayApxRep a == timeOfDayApxRep b + +instance Eq (Apx TimeZone) where + (==) (Apx a) (Apx b) = + a == b + + +utcTimeApxRep (UTCTime d d') = + (d, picoApxRep (unsafeCoerce d')) + +localTimeRep (LocalTime d t) = + (d, timeOfDayApxRep t) + +timetzApxRep (t, tz) = + (timeOfDayApxRep t, tz) + +timeOfDayApxRep :: TimeOfDay -> (Int, Int, Integer) +timeOfDayApxRep (TimeOfDay h m s) = + (h, m, picoApxRep s) + +picoApxRep :: Pico -> Integer +picoApxRep s = + let p = unsafeCoerce s :: Integer + in floor (p % 10^6) + diff --git a/tasty/Main/DB.hs b/tasty/Main/DB.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/DB.hs @@ -0,0 +1,104 @@ +module Main.DB +( + module LibPQ, + session, + oneRow, + unit, + integerDatetimes, +) +where + +import Main.Prelude +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Either +import Control.Monad.IO.Class +import Database.PostgreSQL.LibPQ as LibPQ +import qualified Data.ByteString as ByteString; import Data.ByteString (ByteString) + + +type Session = + EitherT ByteString (ReaderT Connection IO) + +session :: Session a -> IO (Either ByteString a) +session m = + do + c <- connect + initConnection c + r <- runReaderT (runEitherT m) c + finish c + return r + +oneRow :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Format -> Session ByteString +oneRow statement params outFormat = + do + Just result <- result statement params outFormat + Just result <- liftIO $ getvalue result 0 0 + return result + +unit :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Session () +unit statement params = + void $ result statement params Binary + +result :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Format -> Session (Maybe Result) +result statement params outFormat = + do + result <- EitherT $ ReaderT $ \connection -> fmap Right $ execParams connection statement params outFormat + checkResult result + return result + +checkResult :: Maybe Result -> Session () +checkResult result = + EitherT $ ReaderT $ \connection -> do + case result of + Just result -> do + resultErrorField result DiagMessagePrimary >>= maybe (return (Right ())) (return . Left) + Nothing -> do + m <- errorMessage connection + return $ Left $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> m) m + +integerDatetimes :: Session Bool +integerDatetimes = + lift (ReaderT getIntegerDatetimes) + +-- * +------------------------- + +connect :: IO Connection +connect = + connectdb bs + where + bs = + ByteString.intercalate " " components + where + components = + [ + "host=" <> host, + "port=" <> (fromString . show) port, + "user=" <> user, + "password=" <> password, + "dbname=" <> db + ] + where + host = "localhost" + port = 5432 + user = "postgres" + password = "" + db = "postgres" + +initConnection :: Connection -> IO () +initConnection c = + void $ exec c $ mconcat $ map (<> ";") $ + [ + "SET client_min_messages TO WARNING", + "SET client_encoding = 'UTF8'", + "SET intervalstyle = 'postgres'" + ] + +getIntegerDatetimes :: Connection -> IO Bool +getIntegerDatetimes c = + fmap parseResult $ parameterStatus c "integer_datetimes" + where + parseResult = + \case + Just "on" -> True + _ -> False diff --git a/tasty/Main/Gens.hs b/tasty/Main/Gens.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Gens.hs @@ -0,0 +1,118 @@ +module Main.Gens where + +import Main.Prelude hiding (assert, isRight, isLeft) +import Test.QuickCheck +import Test.QuickCheck.Instances +import qualified Main.PTI as PTI +import qualified Data.Scientific as Scientific +import qualified Data.UUID as UUID +import qualified Data.Vector as Vector +import qualified PostgreSQL.Binary.Data as Data +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Data.Text as Text + + +-- * Generators +------------------------- + +auto :: Arbitrary a => Gen a +auto = + arbitrary + +postgresInt :: (Bounded a, Ord a, Integral a, Arbitrary a) => Gen a +postgresInt = + arbitrary >>= \x -> if x > halfMaxBound then postgresInt else pure x + where + halfMaxBound = + div maxBound 2 + +text :: Gen Text +text = + arbitrary >>= \x -> if Text.find (== '\NUL') x == Nothing then return x else text + +char :: Gen Char +char = + arbitrary >>= \x -> if x /= '\NUL' then return x else char + +scientific :: Gen Scientific +scientific = + Scientific.scientific <$> arbitrary <*> arbitrary + +microsTimeOfDay :: Gen TimeOfDay +microsTimeOfDay = + fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ + choose (0, (10^6)*24*60*60) + +microsLocalTime :: Gen LocalTime +microsLocalTime = + LocalTime <$> arbitrary <*> microsTimeOfDay + +microsUTCTime :: Gen UTCTime +microsUTCTime = + localTimeToUTC <$> timeZone <*> microsLocalTime + +intervalDiffTime :: Gen DiffTime +intervalDiffTime = do + unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer) + where + uMin = unsafeCoerce minInterval `div` 10^6 + uMax = unsafeCoerce maxInterval `div` 10^6 + +timeZone :: Gen TimeZone +timeZone = + minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12) + +timetz :: Gen (TimeOfDay, TimeZone) +timetz = + (,) <$> microsTimeOfDay <*> timeZone + +uuid :: Gen UUID.UUID +uuid = + UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +arrayRep :: Gen (Word32, Data.Array) +arrayRep = + do + ndims <- choose (1, 4) + dims <- Vector.replicateM ndims dimGen + (valueGen', oid, arrayOID) <- valueGen + values <- Vector.replicateM (dimsToNValues dims) valueGen' + let nulls = Vector.elem Nothing values + return (arrayOID, (dims, values, nulls, oid)) + where + dimGen = + (,) <$> choose (1, 7) <*> pure 1 + valueGen = + do + (pti, gen) <- elements [(PTI.int8, mkGen Encoder.int8_int64), + (PTI.bool, mkGen Encoder.bool), + (PTI.date, mkGen Encoder.date), + (PTI.text, mkGen Encoder.text_strict), + (PTI.bytea, mkGen Encoder.bytea_strict)] + return (gen, PTI.oidWord32 (PTI.ptiOID pti), PTI.oidWord32 (fromJust (PTI.ptiArrayOID pti))) + where + mkGen renderer = + fmap (fmap (convert . renderer)) arbitrary + dimsToNValues = + Vector.product . fmap dimensionWidth + where + dimensionWidth (x, _) = fromIntegral x + +array3 :: Gen a -> Gen [[[a]]] +array3 gen = + do + width1 <- choose (1, 10) + width2 <- choose (1, 10) + width3 <- choose (1, 10) + replicateM width1 (replicateM width2 (replicateM width3 gen)) + + +-- * Constants +------------------------- + +maxInterval :: DiffTime = + unsafeCoerce $ + (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) + +minInterval :: DiffTime = + negate maxInterval diff --git a/tasty/Main/IO.hs b/tasty/Main/IO.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/IO.hs @@ -0,0 +1,54 @@ +-- | +-- Specific IO Actions +module Main.IO where + +import Main.Prelude hiding (assert, isRight, isLeft) +import Test.QuickCheck +import Test.QuickCheck.Instances +import qualified Main.PTI as PTI +import qualified Main.DB as DB +import qualified Main.TextEncoder as TextEncoder +import qualified Data.Scientific as Scientific +import qualified Data.UUID as UUID +import qualified Data.Vector as Vector +import qualified Data.Text.Encoding as Text +import qualified PostgreSQL.Binary.Data as Data +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified PostgreSQL.Binary.Decoder as Decoder + + +textRoundtrip :: DB.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a) +textRoundtrip oid encoder decoder value = + fmap (either (Left . Text.decodeUtf8) id) $ + DB.session $ do + integerDatetimes <- DB.integerDatetimes + bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) DB.Binary + return $ Decoder.run (decoder integerDatetimes) bytes + where + params integerDatetimes = + [ Just ( oid , bytes , DB.Text ) ] + where + bytes = + (convert . encoder) value + +roundtrip :: DB.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a) +roundtrip oid encoder decoder value = + fmap (either (Left . Text.decodeUtf8) id) $ + DB.session $ do + integerDatetimes <- DB.integerDatetimes + bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) DB.Binary + return $ Decoder.run (decoder integerDatetimes) bytes + where + params integerDatetimes = + [ Just ( oid , bytes , DB.Binary ) ] + where + bytes = + (convert . encoder integerDatetimes) value + +parameterlessStatement :: ByteString -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a) +parameterlessStatement statement decoder value = + fmap (either (Left . Text.decodeUtf8) id) $ + DB.session $ do + integerDatetimes <- DB.integerDatetimes + bytes <- DB.oneRow statement [] DB.Binary + return $ Decoder.run (decoder integerDatetimes) bytes diff --git a/tasty/Main/PTI.hs b/tasty/Main/PTI.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/PTI.hs @@ -0,0 +1,93 @@ +module Main.PTI where + +import BasePrelude hiding (bool) +import qualified Database.PostgreSQL.LibPQ as LibPQ + + +-- | A Postgresql type info +data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) } + +-- | A Word32 and a LibPQ representation of an OID +data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid } + +mkOID :: Word32 -> OID +mkOID x = + OID x ((LibPQ.Oid . fromIntegral) x) + +mkPTI :: Word32 -> Maybe Word32 -> PTI +mkPTI oid arrayOID = + PTI (mkOID oid) (fmap mkOID arrayOID) + + +-- * Constants +------------------------- + +abstime = mkPTI 702 (Just 1023) +aclitem = mkPTI 1033 (Just 1034) +bit = mkPTI 1560 (Just 1561) +bool = mkPTI 16 (Just 1000) +box = mkPTI 603 (Just 1020) +bpchar = mkPTI 1042 (Just 1014) +bytea = mkPTI 17 (Just 1001) +char = mkPTI 18 (Just 1002) +cid = mkPTI 29 (Just 1012) +cidr = mkPTI 650 (Just 651) +circle = mkPTI 718 (Just 719) +cstring = mkPTI 2275 (Just 1263) +date = mkPTI 1082 (Just 1182) +daterange = mkPTI 3912 (Just 3913) +float4 = mkPTI 700 (Just 1021) +float8 = mkPTI 701 (Just 1022) +gtsvector = mkPTI 3642 (Just 3644) +inet = mkPTI 869 (Just 1041) +int2 = mkPTI 21 (Just 1005) +int2vector = mkPTI 22 (Just 1006) +int4 = mkPTI 23 (Just 1007) +int4range = mkPTI 3904 (Just 3905) +int8 = mkPTI 20 (Just 1016) +int8range = mkPTI 3926 (Just 3927) +interval = mkPTI 1186 (Just 1187) +json = mkPTI 114 (Just 199) +line = mkPTI 628 (Just 629) +lseg = mkPTI 601 (Just 1018) +macaddr = mkPTI 829 (Just 1040) +money = mkPTI 790 (Just 791) +name = mkPTI 19 (Just 1003) +numeric = mkPTI 1700 (Just 1231) +numrange = mkPTI 3906 (Just 3907) +oid = mkPTI 26 (Just 1028) +oidvector = mkPTI 30 (Just 1013) +path = mkPTI 602 (Just 1019) +point = mkPTI 600 (Just 1017) +polygon = mkPTI 604 (Just 1027) +record = mkPTI 2249 (Just 2287) +refcursor = mkPTI 1790 (Just 2201) +regclass = mkPTI 2205 (Just 2210) +regconfig = mkPTI 3734 (Just 3735) +regdictionary = mkPTI 3769 (Just 3770) +regoper = mkPTI 2203 (Just 2208) +regoperator = mkPTI 2204 (Just 2209) +regproc = mkPTI 24 (Just 1008) +regprocedure = mkPTI 2202 (Just 2207) +regtype = mkPTI 2206 (Just 2211) +reltime = mkPTI 703 (Just 1024) +text = mkPTI 25 (Just 1009) +tid = mkPTI 27 (Just 1010) +time = mkPTI 1083 (Just 1183) +timestamp = mkPTI 1114 (Just 1115) +timestamptz = mkPTI 1184 (Just 1185) +timetz = mkPTI 1266 (Just 1270) +tinterval = mkPTI 704 (Just 1025) +tsquery = mkPTI 3615 (Just 3645) +tsrange = mkPTI 3908 (Just 3909) +tstzrange = mkPTI 3910 (Just 3911) +tsvector = mkPTI 3614 (Just 3643) +txid_snapshot = mkPTI 2970 (Just 2949) +unknown = mkPTI 705 Nothing +uuid = mkPTI 2950 (Just 2951) +varbit = mkPTI 1562 (Just 1563) +varchar = mkPTI 1043 (Just 1015) +void = mkPTI 2278 Nothing +xid = mkPTI 28 (Just 1011) +xml = mkPTI 142 (Just 143) + diff --git a/tasty/Main/Prelude.hs b/tasty/Main/Prelude.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Prelude.hs @@ -0,0 +1,100 @@ +module Main.Prelude +( + module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + bug, + bottom, + mapLeft, + joinMap, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, Data, fail) + +-- transformers +------------------------- +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 +import Data.Functor.Identity as Exports + +-- conversion +------------------------- +import Conversion as Exports +import Conversion.Text () +import Conversion.ByteString () + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- vector +------------------------- +import Data.Vector as Exports (Vector) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +-- uuid +------------------------- +import Data.UUID as Exports (UUID) + +-- time +------------------------- +import Data.Time as Exports + +-- placeholders +------------------------- +import Development.Placeholders as Exports + +-- loch-th +------------------------- +import Debug.Trace.LocationTH as Exports + +-- custom +------------------------- +import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Builder +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Debug.Trace.LocationTH + + +type LazyByteString = + Data.ByteString.Lazy.ByteString + +type ByteStringBuilder = + Data.ByteString.Builder.Builder + +type LazyText = + Data.Text.Lazy.Text + +type TextBuilder = + Data.Text.Lazy.Builder.Builder + + +bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] + where + msg = "A \"postgresql-binary\" package bug: " :: String + +bottom = [e| $bug "Bottom evaluated" |] + +{-# INLINE mapLeft #-} +mapLeft :: (a -> b) -> Either a x -> Either b x +mapLeft f = + either (Left . f) Right + +joinMap :: Monad m => (a -> m b) -> m a -> m b +joinMap f = + join . fmap f diff --git a/tasty/Main/Properties.hs b/tasty/Main/Properties.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Properties.hs @@ -0,0 +1,29 @@ +module Main.Properties where + +import Main.Prelude hiding (assert, isRight, isLeft) +import Test.QuickCheck +import Test.QuickCheck.Instances +import qualified Data.Scientific as Scientific +import qualified Data.UUID as UUID +import qualified Data.Vector as Vector +import qualified PostgreSQL.Binary.Data as Data +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified Main.TextEncoder as TextEncoder +import qualified Main.PTI as PTI +import qualified Main.DB as DB +import qualified Main.IO as IO + + +roundtrip :: (Show a, Eq a) => + DB.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder a) -> a -> Property +roundtrip oid encoder decoder value = + Right value === unsafePerformIO (IO.roundtrip oid encoder decoder value) + +stdRoundtrip :: (Show a, Eq a) => DB.Oid -> Encoder.Encoder a -> Decoder.Decoder a -> a -> Property +stdRoundtrip oid encoder decoder value = + roundtrip oid (const encoder) (const decoder) value + +textRoundtrip :: (Show a, Eq a) => DB.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> Property +textRoundtrip oid encoder decoder value = + Right value === unsafePerformIO (IO.textRoundtrip oid encoder decoder value) diff --git a/tasty/Main/TextEncoder.hs b/tasty/Main/TextEncoder.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/TextEncoder.hs @@ -0,0 +1,62 @@ +-- | +-- Encoders to text format. +module Main.TextEncoder where + +import Main.Prelude hiding (maybe, bool) +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Scientific +import qualified Data.Text.Encoding +import qualified Data.UUID +import qualified Main.Prelude as Prelude + +type Encoder a = + a -> Builder + +bool :: Encoder Bool +bool = + byteString . Prelude.bool "false" "true" + +int2_int16 :: Encoder Int16 +int2_int16 = + int16Dec + +int4_int32 :: Encoder Int32 +int4_int32 = + int32Dec + +int8_int64 :: Encoder Int64 +int8_int64 = + int64Dec + +int2_word16 :: Encoder Word16 +int2_word16 = + word16Dec + +int4_word32 :: Encoder Word32 +int4_word32 = + word32Dec + +int8_word64 :: Encoder Word64 +int8_word64 = + word64Dec + +float4 :: Encoder Float +float4 = + floatDec + +float8 :: Encoder Double +float8 = + doubleDec + +numeric :: Encoder Scientific +numeric = + Data.ByteString.Builder.Scientific.scientificBuilder + +uuid :: Encoder UUID +uuid = + byteString . Data.UUID.toASCIIBytes + +bytea_strict :: Encoder ByteString +bytea_strict = + byteString +