diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2014, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/executables/Decoding.hs b/executables/Decoding.hs new file mode 100644 --- /dev/null +++ b/executables/Decoding.hs @@ -0,0 +1,44 @@ +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 (E.time (read "10:41:06")), + b "timetz" D.timetz (E.timetz (read "(10:41:06, +0300)")), + b "timestamp" D.timestamp (E.timestamp (read "2000-01-19 10:41:06")), + b "timestamptz" D.timestamptz (E.timestamptz (read "2000-01-19 10:41:06")), + b "interval" D.interval (E.interval (secondsToDiffTime 23472391470128374)), + b "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 new file mode 100644 --- /dev/null +++ b/executables/Encoding.hs @@ -0,0 +1,43 @@ +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 (read "10:41:06"), + b "timetz" E.timetz (read "(10:41:06, +0300)"), + b "timestamp" E.timestamp (read "2000-01-19 10:41:06"), + b "timestamptz" E.timestamptz (read "2000-01-19 10:41:06"), + b "interval" E.interval (secondsToDiffTime 23472391470128374), + b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"), + b "array" E.array (Array.fromListUnsafe + [Array.fromSingleton (Just "dfs") True 0, + Array.fromSingleton Nothing True 0]) + ] + where + b name encoder value = + bench name $ nf encoder value diff --git a/executables/Tests.hs b/executables/Tests.hs new file mode 100644 --- /dev/null +++ b/executables/Tests.hs @@ -0,0 +1,440 @@ +{-# 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 + Just result <- + let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> encode v <*> pure PQ.Binary + in PQ.execParams c "SELECT $1" [param] PQ.Binary + binaryResult <- PQ.getvalue result 0 0 + PQ.finish c + return $ decode binaryResult + +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 standard_conforming_strings TO on", + "SET datestyle TO ISO", + "SET client_encoding = 'UTF8'", + "SET client_min_messages TO WARNING", + "SET bytea_output = 'hex'" ] + +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 = + timeToTimeOfDay <$> microsDiffTimeGen + +microsLocalTimeGen :: Gen LocalTime +microsLocalTimeGen = + LocalTime <$> arbitrary <*> microsTimeOfDayGen + +microsUTCTimeGen :: Gen UTCTime +microsUTCTimeGen = + localTimeToUTC <$> timeZoneGen <*> microsLocalTimeGen + +microsDiffTimeGen :: Gen DiffTime +microsDiffTimeGen = do + fmap picosecondsToDiffTime $ fmap (* (10^6)) $ choose (0, (10^6)*24*60*60) + +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 + + +-- * Properties +------------------------- + +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 + +prop_interval = + forAll microsDiffTimeGen $ + mappingP (PTI.oidOf PTI.interval) + (nonNullRenderer Encoder.interval) + (nonNullParser Decoder.interval) + +test_intervalParsing = + assertEqual (Right (secondsToDiffTime (44 + 60 * (10 + 60 * 24 * (20 + 31 * 2))))) =<< do + fmap (Decoder.interval . fromJust) $ + query "SELECT 'P0000-02-20T00:10:44' :: interval" [] PQ.Binary + +prop_timestamp = + forAll microsUTCTimeGen $ + mappingP (PTI.oidOf PTI.timestamp) + (nonNullRenderer Encoder.timestamp) + (nonNullParser Decoder.timestamp) + +test_timestampParsing1 = + assertEqual (Right (read "2000-01-19 10:41:06" :: UTCTime)) =<< do + fmap (Decoder.timestamp . fromJust) $ + query "SELECT '2000-01-19 10:41:06' :: timestamp" [] PQ.Binary + +prop_timestamptz = + forAll microsLocalTimeGen $ + mappingP (PTI.oidOf PTI.timestamptz) + (nonNullRenderer Encoder.timestamptz) + (nonNullParser Decoder.timestamptz) + +prop_timetz = + forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ + mappingP (PTI.oidOf PTI.timetz) + (nonNullRenderer Encoder.timetz) + (nonNullParser Decoder.timetz) + +test_timetzParsing1 = + assertEqual (Right (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do + fmap (Decoder.timetz . fromJust) $ + query "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary + +prop_timeOfDay = + forAll microsTimeOfDayGen $ + mappingP (PTI.oidOf PTI.time) + (nonNullRenderer Encoder.time) + (nonNullParser Decoder.time) + +prop_timeOfDayParsing = + forAll microsTimeOfDayGen $ \x -> + Right x === do + unsafePerformIO $ + fmap (Decoder.time . fromJust) $ + query "SELECT $1" + [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)] + PQ.Binary + +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/PostgreSQLBinary/Array.hs b/library/PostgreSQLBinary/Array.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Array.hs @@ -0,0 +1,73 @@ +-- | +-- 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/Date.hs b/library/PostgreSQLBinary/Date.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Date.hs @@ -0,0 +1,39 @@ +module PostgreSQLBinary.Date where + +import PostgreSQLBinary.Prelude +import Data.Time.Calendar.Julian + + +type YMD = (Integer, Int, Int) + +{-# INLINE dayToJulianYMD #-} +dayToJulianYMD :: Day -> YMD +dayToJulianYMD = + toJulian + +{-# INLINE dayToGregorianYMD #-} +dayToGregorianYMD :: Day -> YMD +dayToGregorianYMD = + toGregorian + +{-# INLINABLE ymdToInt #-} +ymdToInt :: YMD -> Int +ymdToInt (y, m, d) = + let (m', y') = if m > 2 then (m + 1, fromIntegral $ y + 4800) + else (m + 13, fromIntegral $ y + 4799) + century = y' `div` 100 + in + y' * 365 - 32167 + + y' `div` 4 - century + century `div` 4 + + 7834 * m' `div` 256 + d + +{-# INLINABLE dayToPostgresJulian #-} +dayToPostgresJulian :: Day -> Integer +dayToPostgresJulian = + (+ (2400001 - 2451545)) . toModifiedJulianDay + +{-# INLINABLE postgresJulianToDay #-} +postgresJulianToDay :: Integer -> Day +postgresJulianToDay = + ModifiedJulianDay . (subtract (2400001 - 2451545)) + diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Decoder.hs @@ -0,0 +1,189 @@ +module PostgreSQLBinary.Decoder where + +import PostgreSQLBinary.Prelude hiding (bool) +import qualified Data.ByteString as B +import qualified Data.ByteString.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.Atto as Atto +import qualified PostgreSQLBinary.Decoder.Zepto as Zepto +import qualified PostgreSQLBinary.Array as Array +import qualified PostgreSQLBinary.Date as Date +import qualified PostgreSQLBinary.Integral as Integral +import qualified PostgreSQLBinary.Numeric as Numeric + + +-- | +-- 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 = + evalStateT $ do + componentsAmount <- intOfSize 2 + pointIndex :: Int16 <- intOfSize 2 + signCode <- intOfSize 2 + modify (B.drop 2) + components <- replicateM componentsAmount (intOfSize 2) + signer <- + if | signCode == Numeric.negSignCode -> return negate + | signCode == Numeric.posSignCode -> return id + | signCode == Numeric.nanSignCode -> lift $ Left "NAN sign" + | otherwise -> lift $ Left $ "Unexpected sign value: " <> (fromString . show) signCode + let + c = signer $ fromIntegral $ (Numeric.mergeComponents components :: Word64) + e = (fromIntegral (pointIndex + 1) - length components) * 4 + in return $ Scientific.scientific c e + where + intOfSize n = + lift . int =<< state (B.splitAt n) + + +-- * 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 (Date.postgresJulianToDay . fromIntegral) . (int :: D Int32) + +{-# INLINABLE time #-} +time :: D TimeOfDay +time = + fmap (timeToTimeOfDay . picosecondsToDiffTime . (* (10^6)) . fromIntegral) . + (int :: D Word64) + +{-# INLINABLE timetz #-} +timetz :: D (TimeOfDay, TimeZone) +timetz = + \x -> + let (timeX, zoneX) = B.splitAt 8 x + in (,) <$> time timeX <*> tz zoneX + where + tz = + fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32) + +{-# INLINABLE timestamp #-} +timestamp :: D UTCTime +timestamp = + fmap fromMicros . (int :: D Int64) + where + fromMicros = + evalState $ do + days <- state $ (`divMod` (10^6 * 60 * 60 * 24)) + micros <- get + return $ + UTCTime + (Date.postgresJulianToDay . fromIntegral $ days) + (picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros) + +{-# INLINABLE timestamptz #-} +timestamptz :: D LocalTime +timestamptz = + fmap fromMicros . (int :: D Int64) + where + fromMicros = + evalState $ do + days <- state $ (`divMod` (10^6 * 60 * 60 * 24)) + micros <- get + return $ + LocalTime + (Date.postgresJulianToDay . fromIntegral $ days) + (timeToTimeOfDay . picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros) + +{-# INLINABLE interval #-} +interval :: D DiffTime +interval = + evalStateT $ do + ub <- state $ B.splitAt 8 + db <- state $ B.splitAt 4 + mb <- get + lift $ do + u <- int ub + d <- int db + m <- int mb + return $ picosecondsToDiffTime $ fromIntegral $ + (10 ^ 6 * (u + 10 ^ 6 * 60 * 60 * 24 * (d + 31 * m)) :: Int) + + + +-- * 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/Atto.hs b/library/PostgreSQLBinary/Decoder/Atto.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Decoder/Atto.hs @@ -0,0 +1,45 @@ +-- | +-- Composable Attoparsec parsers. +module PostgreSQLBinary.Decoder.Atto where + +import PostgreSQLBinary.Prelude hiding (take, bool) +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 hiding (double) +import qualified PostgreSQLBinary.Integral as Integral +import qualified PostgreSQLBinary.Array as Array +import qualified Data.Scientific as Scientific + + +{-# INLINABLE run #-} +run :: ByteString -> Parser a -> Either Text a +run input parser = + onResult $ parse (parser <* endOfInput) input + where + onResult = + \case + Fail remainder contexts message -> + Left $ "Message: " <> (fromString . show) message <> "; " <> + "Contexts: " <> (fromString . show) contexts <> "; " <> + "Failing input: " <> (fromString . show) remainder + Partial c -> + onResult $ c mempty + Done _ result -> + Right result + +{-# INLINE integral #-} +integral :: forall a. (Integral a, Bits a) => Parser a +integral = + intOfSize (Integral.byteSize (undefined :: a)) + +{-# INLINE intOfSize #-} +intOfSize :: (Integral a, Bits a) => Int -> Parser a +intOfSize x = + Integral.pack <$> take x + +bool :: Parser Bool +bool = + (word8 0 *> pure False) <|> (word8 1 *> pure True) + +double :: Parser Double +double = + unsafeCoerce (intOfSize 8 :: Parser Int64) diff --git a/library/PostgreSQLBinary/Decoder/Zepto.hs b/library/PostgreSQLBinary/Decoder/Zepto.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Decoder/Zepto.hs @@ -0,0 +1,52 @@ +-- | +-- 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 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 + diff --git a/library/PostgreSQLBinary/Encoder.hs b/library/PostgreSQLBinary/Encoder.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Encoder.hs @@ -0,0 +1,145 @@ +module PostgreSQLBinary.Encoder where + +import PostgreSQLBinary.Prelude +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.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.Date as Date +import qualified PostgreSQLBinary.Integral as Integral +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 + +{-# INLINABLE time #-} +time :: E TimeOfDay +time = + Builder.run . Builder.time + +{-# INLINABLE timetz #-} +timetz :: E (TimeOfDay, TimeZone) +timetz = + Builder.run . Builder.timetz + +{-# INLINABLE timestamp #-} +timestamp :: E UTCTime +timestamp = + Builder.run . Builder.timestamp + +{-# INLINABLE timestamptz #-} +timestamptz :: E LocalTime +timestamptz = + Builder.run . Builder.timestamptz + +{-# INLINABLE interval #-} +interval :: E DiffTime +interval = + Builder.run . Builder.interval + +-- * 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 new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Encoder/Builder.hs @@ -0,0 +1,136 @@ +module PostgreSQLBinary.Encoder.Builder where + +import PostgreSQLBinary.Prelude hiding (bool) +import Data.ByteString.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.Date as Date +import qualified PostgreSQLBinary.Numeric as Numeric + + +{-# 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 . Date.dayToPostgresJulian + +{-# INLINE time #-} +time :: TimeOfDay -> Builder +time = + word64BE . (`div` (10^6)) . unsafeCoerce timeOfDayToTime + +{-# INLINE timetz #-} +timetz :: (TimeOfDay, TimeZone) -> Builder +timetz (timeX, tzX) = + time timeX <> tz tzX + +{-# INLINE tz #-} +tz :: TimeZone -> Builder +tz = + int32BE . fromIntegral . (*60) . negate . timeZoneMinutes + +{-# INLINE timestamp #-} +timestamp :: UTCTime -> Builder +timestamp (UTCTime dayX timeX) = + let days = Date.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 + time = (`div` (10^6)) . unsafeCoerce $ timeX + in int64BE $ fromIntegral $ days + time + +{-# INLINE timestamptz #-} +timestamptz :: LocalTime -> Builder +timestamptz (LocalTime dayX timeX) = + let days = Date.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 + time = (`div` (10^6)) . unsafeCoerce timeOfDayToTime $ timeX + in int64BE $ fromIntegral $ days + time + +{-# INLINE interval #-} +interval :: DiffTime -> Builder +interval x = + flip evalState (unsafeCoerce x :: Integer) $ do + u <- state (`divMod` (10 ^ 6)) + d <- state (`divMod` (10 ^ 6 * 60 * 60 * 24)) + m <- get + return $ + int64BE (fromIntegral u) <> int32BE (fromIntegral d) <> int32BE (fromIntegral m) + +{-# INLINE numeric #-} +numeric :: Scientific -> Builder +numeric x = + word16BE (fromIntegral componentsAmount) <> + int16BE (fromIntegral pointIndex) <> + word16BE signCode <> + word16BE (fromIntegral trimmedExponent) <> + foldMap word16BE 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 new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Integral.hs @@ -0,0 +1,24 @@ +-- | +-- 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/Numeric.hs b/library/PostgreSQLBinary/Numeric.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Numeric.hs @@ -0,0 +1,38 @@ +module PostgreSQLBinary.Numeric where + +import PostgreSQLBinary.Prelude + + +posSignCode = 0x0000 :: Word16 +negSignCode = 0x4000 :: Word16 +nanSignCode = 0xC000 :: Word16 + +{-# INLINE extractComponents #-} +extractComponents :: Integral a => a -> [Word16] +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 :: Word16 -> [Word16] +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 new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Prelude.hs @@ -0,0 +1,63 @@ +module PostgreSQLBinary.Prelude +( + module Exports, + LazyByteString, + LazyText, + bug, + bottom, + partial, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports + +-- mtl-prelude +------------------------- +import MTLPrelude as Exports hiding (shift) + +-- 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/postgresql-binary.cabal b/postgresql-binary.cabal new file mode 100644 --- /dev/null +++ b/postgresql-binary.cabal @@ -0,0 +1,176 @@ +name: + postgresql-binary +version: + 0.1.0 +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., + is based on this library. +category: + Database, Codecs, Parsing +homepage: + https://github.com/nikita-volkov/postgresql-binary +bug-reports: + https://github.com/nikita-volkov/postgresql-binary/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2014, Nikita Volkov +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 + + +source-repository head + type: + git + location: + git://github.com/nikita-volkov/postgresql-binary.git + + +library + hs-source-dirs: + library + ghc-options: + -funbox-strict-fields + 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: + Haskell2010 + other-modules: + PostgreSQLBinary.Prelude + PostgreSQLBinary.Encoder.Builder + PostgreSQLBinary.Decoder.Atto + PostgreSQLBinary.Decoder.Zepto + PostgreSQLBinary.Integral + PostgreSQLBinary.Numeric + PostgreSQLBinary.Date + exposed-modules: + PostgreSQLBinary.Array + PostgreSQLBinary.Encoder + PostgreSQLBinary.Decoder + build-depends: + -- parsers: + attoparsec == 0.12.*, + -- data: + uuid == 1.3.*, + time >= 1.4 && < 1.6, + scientific == 0.3.*, + text >= 1 && < 1.3, + bytestring >= 0.10 && < 0.11, + -- errors: + loch-th == 0.2.*, + placeholders == 0.1.*, + -- general: + mtl-prelude == 2.0.*, + base-prelude >= 0.1.3 && < 0.2, + base >= 4.5 && < 4.8 + + +test-suite tests + type: + exitcode-stdio-1.0 + hs-source-dirs: + executables + main-is: + Tests.hs + ghc-options: + -threaded + "-with-rtsopts=-N" + -funbox-strict-fields + 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: + Haskell2010 + build-depends: + -- testing: + postgresql-binary, + HTF == 0.12.*, + quickcheck-instances == 0.3.*, + QuickCheck == 2.7.*, + -- database: + postgresql-libpq == 0.9.*, + -- data: + uuid == 1.3.*, + time >= 1.4 && < 1.6, + scientific == 0.3.*, + text >= 1 && < 1.3, + bytestring >= 0.10 && < 0.11, + -- general: + base-prelude >= 0.1.3 && < 0.2, + base >= 4.5 && < 4.8 + + +benchmark decoding + type: + exitcode-stdio-1.0 + hs-source-dirs: + executables + main-is: + Decoding.hs + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + -funbox-strict-fields + 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: + Haskell2010 + build-depends: + postgresql-binary, + -- benchmarking: + criterion == 1.0.*, + -- data: + time >= 1.4 && < 1.6, + scientific == 0.3.*, + text >= 1 && < 1.3, + bytestring >= 0.10 && < 0.11, + -- general: + deepseq == 1.3.*, + mtl-prelude == 2.0.*, + base-prelude >= 0.1.3 && < 0.2, + base >= 4.5 && < 4.8 + + +benchmark encoding + type: + exitcode-stdio-1.0 + hs-source-dirs: + executables + main-is: + Encoding.hs + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + -funbox-strict-fields + 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: + Haskell2010 + build-depends: + postgresql-binary, + -- benchmarking: + criterion == 1.0.*, + -- data: + time >= 1.4 && < 1.6, + scientific == 0.3.*, + text >= 1 && < 1.3, + bytestring >= 0.10 && < 0.11, + -- general: + deepseq == 1.3.*, + mtl-prelude == 2.0.*, + base-prelude >= 0.1.3 && < 0.2, + base >= 4.5 && < 4.8