diff --git a/hasql-postgres.cabal b/hasql-postgres.cabal --- a/hasql-postgres.cabal +++ b/hasql-postgres.cabal @@ -1,10 +1,15 @@ name: hasql-postgres version: - 0.1.1 + 0.1.2 synopsis: - A "PostgreSQL" driver for the "hasql" library + A "PostgreSQL" backend for the "hasql" library description: + This library provides a \"PostgreSQL\" driver for + . + . + The included benchmarks prove it to be performing up to 1.5 times faster then + the \"postgresql-simple\" library. category: Database homepage: @@ -47,7 +52,8 @@ Hasql.Postgres.Prelude Hasql.Postgres.Renderer Hasql.Postgres.ErrorCode - Hasql.Postgres.OID + Hasql.Postgres.PTI + Hasql.Postgres.OIDMapping Hasql.Postgres.Statement Hasql.Postgres.Parser Hasql.Postgres.StatementPreparer @@ -59,12 +65,15 @@ exposed-modules: Hasql.Postgres build-depends: + -- template haskell: + template-haskell == 2.*, -- parsers: attoparsec == 0.12.*, -- database: hasql-backend == 0.1.*, postgresql-libpq == 0.9.*, -- data: + base16-bytestring == 0.1.*, vector == 0.10.*, old-locale == 1.0.*, time == 1.4.*, @@ -107,12 +116,15 @@ quickcheck-instances == 0.3.*, QuickCheck == 2.7.*, HUnit == 1.2.*, + -- template haskell: + template-haskell == 2.*, -- parsers: attoparsec == 0.12.*, -- database: hasql == 0.1.*, postgresql-libpq == 0.9.*, -- data: + base16-bytestring == 0.1.*, vector == 0.10.*, utf8-string >= 0.3.8 && < 0.4, old-locale == 1.0.*, @@ -163,6 +175,7 @@ SafeSemaphore == 0.10.*, slave-thread == 0.1.*, -- data: + vector == 0.10.*, old-locale == 1.0.*, time == 1.4.*, scientific == 0.3.*, diff --git a/library-tests/Main.hs b/library-tests/Main.hs --- a/library-tests/Main.hs +++ b/library-tests/Main.hs @@ -5,6 +5,7 @@ import Hasql.Postgres.Prelude import {-@ HTF_TESTS @-} Hasql.Postgres.ParserTests +import {-@ HTF_TESTS @-} Hasql.Postgres.ParserAndRendererTests import {-@ HTF_TESTS @-} Hasql.Postgres.TemplateConverterTests main = diff --git a/library/Hasql/Postgres.hs b/library/Hasql/Postgres.hs --- a/library/Hasql/Postgres.hs +++ b/library/Hasql/Postgres.hs @@ -15,9 +15,10 @@ import qualified Hasql.Postgres.TemplateConverter as TemplateConverter import qualified Hasql.Postgres.Parser as Parser import qualified Hasql.Postgres.Renderer as Renderer -import qualified Hasql.Postgres.OID as OID +import qualified Hasql.Postgres.OIDMapping as OIDMapping import qualified Data.Text.Encoding as Text import qualified ListT +import qualified Language.Haskell.TH as TH -- | @@ -142,138 +143,8 @@ -- * Mappings ------------------------- --- | Maps to the same type as the underlying value, --- encoding the 'Nothing' as /NULL/. -instance Backend.Mapping Postgres a => Backend.Mapping Postgres (Maybe a) where - renderValue = - \case - Nothing -> - case Backend.renderValue (undefined :: a) of - StatementArgument (oid, _) -> StatementArgument (oid, Nothing) - Just v -> - Backend.renderValue v - parseResult = traverse (Backend.parseResult . Result . Just) . unpackResult - --- | Maps to \"bool\". -instance Backend.Mapping Postgres Bool where - renderValue = mkRenderValue PQ.Text OID.bool Renderer.bool - parseResult = mkParseResult Parser.bool - --- | Maps to \"int8\". -instance Backend.Mapping Postgres Int where - renderValue = mkRenderValue PQ.Text OID.int8 Renderer.int - parseResult = mkParseResult Parser.integral - --- | Maps to \"int2\". -instance Backend.Mapping Postgres Int8 where - renderValue = mkRenderValue PQ.Text OID.int2 Renderer.int8 - parseResult = mkParseResult Parser.integral - --- | Maps to \"int2\". -instance Backend.Mapping Postgres Int16 where - renderValue = mkRenderValue PQ.Text OID.int2 Renderer.int16 - parseResult = mkParseResult Parser.integral - --- | Maps to \"int4\". -instance Backend.Mapping Postgres Int32 where - renderValue = mkRenderValue PQ.Text OID.int4 Renderer.int32 - parseResult = mkParseResult Parser.integral - --- | Maps to \"int8\". -instance Backend.Mapping Postgres Int64 where - renderValue = mkRenderValue PQ.Text OID.int8 Renderer.int64 - parseResult = mkParseResult Parser.integral - --- | Maps to \"int8\". -instance Backend.Mapping Postgres Word where - renderValue = mkRenderValue PQ.Text OID.int8 Renderer.word - parseResult = mkParseResult Parser.unsignedIntegral - --- | Maps to \"int2\". -instance Backend.Mapping Postgres Word8 where - renderValue = mkRenderValue PQ.Text OID.int2 Renderer.word8 - parseResult = mkParseResult Parser.unsignedIntegral - --- | Maps to \"int4\". -instance Backend.Mapping Postgres Word16 where - renderValue = mkRenderValue PQ.Text OID.int4 Renderer.word16 - parseResult = mkParseResult Parser.unsignedIntegral - --- | Maps to \"int8\". -instance Backend.Mapping Postgres Word32 where - renderValue = mkRenderValue PQ.Text OID.int8 Renderer.word32 - parseResult = mkParseResult Parser.unsignedIntegral - --- | Maps to \"int8\". -instance Backend.Mapping Postgres Word64 where - renderValue = mkRenderValue PQ.Text OID.int8 Renderer.word64 - parseResult = mkParseResult Parser.unsignedIntegral - --- | Maps to \"float4\". -instance Backend.Mapping Postgres Float where - renderValue = mkRenderValue PQ.Text OID.float4 Renderer.float - parseResult = mkParseResult Parser.float - --- | Maps to \"float8\". -instance Backend.Mapping Postgres Double where - renderValue = mkRenderValue PQ.Text OID.float8 Renderer.double - parseResult = mkParseResult Parser.double - --- | Maps to \"numeric\". -instance Backend.Mapping Postgres Scientific where - renderValue = mkRenderValue PQ.Text OID.numeric Renderer.scientific - parseResult = mkParseResult Parser.scientific - --- | Maps to \"date\". -instance Backend.Mapping Postgres Day where - renderValue = mkRenderValue PQ.Text OID.date Renderer.day - parseResult = mkParseResult Parser.day - --- | Maps to \"time\". -instance Backend.Mapping Postgres TimeOfDay where - renderValue = mkRenderValue PQ.Text OID.time Renderer.timeOfDay - parseResult = mkParseResult Parser.timeOfDay - --- | Maps to \"timestamp\". -instance Backend.Mapping Postgres LocalTime where - renderValue = mkRenderValue PQ.Text OID.timestamp Renderer.localTime - parseResult = mkParseResult Parser.localTime - --- | Maps to \"timestamptz\". -instance Backend.Mapping Postgres ZonedTime where - renderValue = mkRenderValue PQ.Text OID.timestamptz Renderer.zonedTime - parseResult = mkParseResult Parser.zonedTime - --- | Maps to \"timestamp\". -instance Backend.Mapping Postgres UTCTime where - renderValue = mkRenderValue PQ.Text OID.timestamp Renderer.utcTime - parseResult = mkParseResult Parser.utcTime - --- | Maps to \"varchar\". -instance Backend.Mapping Postgres Char where - renderValue = mkRenderValue PQ.Text OID.varchar Renderer.char - parseResult = mkParseResult Parser.utf8Char - --- | Maps to \"text\". -instance Backend.Mapping Postgres Text where - renderValue = mkRenderValue PQ.Text OID.text Renderer.text - parseResult = mkParseResult Parser.utf8Text - --- | Maps to \"text\". -instance Backend.Mapping Postgres LazyText where - renderValue = mkRenderValue PQ.Text OID.text Renderer.lazyText - parseResult = mkParseResult Parser.utf8LazyText - --- | Maps to \"bytea\". -instance Backend.Mapping Postgres ByteString where - renderValue = mkRenderValue PQ.Binary OID.bytea Renderer.byteString - parseResult = mkParseResult Parser.byteString - --- | Maps to \"bytea\". -instance Backend.Mapping Postgres LazyByteString where - renderValue = mkRenderValue PQ.Binary OID.bytea Renderer.lazyByteString - parseResult = mkParseResult Parser.lazyByteString - +-- ** Helpers +------------------------- -- | -- Make a 'renderValue' function. @@ -287,5 +158,80 @@ mkParseResult p (Result r) = do r' <- maybe (Left "Null result") Right r - left (\t -> "Input: " <> Text.decodeLatin1 r' <> ". Error: " <> t) $ + left (\t -> t <> "; Input: " <> (fromString . show) r') $ Parser.run r' p + +-- ** Instances +------------------------- + +-- | Maps to the same type as the underlying value, +-- encoding the 'Nothing' as /NULL/. +instance Backend.Mapping Postgres a => Backend.Mapping Postgres (Maybe a) where + renderValue = + \case + Nothing -> + case Backend.renderValue ($bottom :: a) of + StatementArgument (oid, _) -> StatementArgument (oid, Nothing) + Just v -> + Backend.renderValue v + parseResult = + traverse (Backend.parseResult . Result . Just) . unpackResult + +instance (Backend.Mapping Postgres a, Renderer.Renderable a, Parser.Parsable a, OIDMapping.OIDMapping a) => + Backend.Mapping Postgres (Vector a) where + renderValue = + mkRenderValue PQ.Text (OIDMapping.identifyOID (undefined :: Vector a)) (Renderer.renderer Nothing) + parseResult = + mkParseResult (Parser.parser Nothing) + +-- | +-- Maps to Postgres arrays. +-- +-- Please note that since @String@ is just an alias to @[Char]@, +-- it will be mapped to an array of characters. +-- If you want to map to a textual type use @Text@ instead. +instance (Backend.Mapping Postgres a, Renderer.Renderable a, Parser.Parsable a, OIDMapping.OIDMapping a) => + Backend.Mapping Postgres [a] where + renderValue = + mkRenderValue PQ.Text (OIDMapping.identifyOID (undefined :: [a])) (Renderer.renderer Nothing) + parseResult = + mkParseResult (Parser.parser Nothing) + +let + types = + [ ''Bool, + ''Int, + ''Int8, + ''Int16, + ''Int32, + ''Int64, + ''Word, + ''Word8, + ''Word16, + ''Word32, + ''Word64, + ''Float, + ''Double, + ''Scientific, + ''Day, + ''TimeOfDay, + ''LocalTime, + ''ZonedTime, + ''UTCTime, + ''Char, + ''Text, + ''LazyText, + ''ByteString, + ''LazyByteString ] + in + fmap concat $ forM types $ \t -> + [d| + instance Backend.Mapping Postgres $(TH.conT t) where + renderValue = + mkRenderValue + PQ.Text + (OIDMapping.identifyOID (undefined :: $(TH.conT t))) + (Renderer.renderer Nothing) + parseResult = + mkParseResult (Parser.parser Nothing) + |] diff --git a/library/Hasql/Postgres/OID.hs b/library/Hasql/Postgres/OID.hs deleted file mode 100644 --- a/library/Hasql/Postgres/OID.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Hasql.Postgres.OID where - -import Database.PostgreSQL.LibPQ (Oid(..)) - - -type OID = Oid - -abstime :: OID = Oid 702 -anyarray :: OID = Oid 2277 -bit :: OID = Oid 1560 -bool :: OID = Oid 16 -box :: OID = Oid 603 -bpchar :: OID = Oid 1042 -bytea :: OID = Oid 17 -char :: OID = Oid 18 -cid :: OID = Oid 29 -cidr :: OID = Oid 650 -circle :: OID = Oid 718 -date :: OID = Oid 1082 -float4 :: OID = Oid 700 -float8 :: OID = Oid 701 -gtsvector :: OID = Oid 3642 -inet :: OID = Oid 869 -int2 :: OID = Oid 21 -int2vector :: OID = Oid 22 -int4 :: OID = Oid 23 -int8 :: OID = Oid 20 -interval :: OID = Oid 1186 -json :: OID = Oid 114 -line :: OID = Oid 628 -lseg :: OID = Oid 601 -macaddr :: OID = Oid 829 -money :: OID = Oid 790 -name :: OID = Oid 19 -numeric :: OID = Oid 1700 -oid :: OID = Oid 26 -path :: OID = Oid 602 -point :: OID = Oid 600 -polygon :: OID = Oid 604 -record :: OID = Oid 2249 -refcursor :: OID = Oid 1790 -regproc :: OID = Oid 24 -reltime :: OID = Oid 703 -text :: OID = Oid 25 -tid :: OID = Oid 27 -time :: OID = Oid 1083 -timestamp :: OID = Oid 1114 -timestamptz :: OID = Oid 1184 -timetz :: OID = Oid 1266 -tinterval :: OID = Oid 704 -tsvector :: OID = Oid 3614 -unknown :: OID = Oid 705 -uuid :: OID = Oid 2950 -varbit :: OID = Oid 1562 -varchar :: OID = Oid 1043 -void :: OID = Oid 2278 -xid :: OID = Oid 28 -xml :: OID = Oid 142 diff --git a/library/Hasql/Postgres/OIDMapping.hs b/library/Hasql/Postgres/OIDMapping.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Postgres/OIDMapping.hs @@ -0,0 +1,63 @@ +module Hasql.Postgres.OIDMapping where + +import Hasql.Postgres.Prelude hiding (bool) +import Database.PostgreSQL.LibPQ (Oid(..)) +import qualified Language.Haskell.TH as TH +import qualified Hasql.Postgres.PTI as PTI + + +class OIDMapping a where + identifyOID :: a -> Oid + identifyArrayOID :: a -> Oid + +instance OIDMapping a => OIDMapping (Maybe a) where + identifyOID = const $ identifyOID (undefined :: a) + identifyArrayOID = const $ identifyArrayOID (undefined :: a) + +instance OIDMapping a => OIDMapping [a] where + identifyOID = const $ identifyArrayOID (undefined :: a) + identifyArrayOID = identifyOID + +instance OIDMapping a => OIDMapping (Vector a) where + identifyOID = const $ identifyArrayOID (undefined :: a) + identifyArrayOID = identifyOID + +let + mappings = + [ (''Bool , PTI.bool ), + (''Int , PTI.int8 ), + (''Int8 , PTI.int2 ), + (''Int16 , PTI.int2 ), + (''Int32 , PTI.int4 ), + (''Int64 , PTI.int8 ), + (''Word , PTI.int8 ), + (''Word8 , PTI.int2 ), + (''Word16 , PTI.int4 ), + (''Word32 , PTI.int8 ), + (''Word64 , PTI.int8 ), + (''Float , PTI.float4 ), + (''Double , PTI.float8 ), + (''Scientific , PTI.numeric ), + (''Day , PTI.date ), + (''TimeOfDay , PTI.time ), + (''LocalTime , PTI.timestamp ), + (''ZonedTime , PTI.timestamptz), + (''UTCTime , PTI.timestamp ), + (''Char , PTI.varchar ), + (''Text , PTI.text ), + (''LazyText , PTI.text ), + (''ByteString , PTI.bytea ), + (''LazyByteString, PTI.bytea ) ] + oidInt (Oid x) = + fromIntegral x + in + fmap join $ forM mappings $ \(t, pti) -> + [d| + instance OIDMapping $(TH.conT t) where + {-# INLINE identifyOID #-} + identifyOID = + const $ Oid $(TH.litE $ TH.integerL $ oidInt $ PTI.oidOf pti) + {-# INLINE identifyArrayOID #-} + identifyArrayOID = + const $ Oid $(TH.litE $ TH.integerL $ oidInt $ fromMaybe (PTI.oidOf PTI.unknown) (PTI.arrayOIDOf pti)) + |] diff --git a/library/Hasql/Postgres/PTI.hs b/library/Hasql/Postgres/PTI.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Postgres/PTI.hs @@ -0,0 +1,78 @@ +module Hasql.Postgres.PTI where + +import Hasql.Postgres.Prelude hiding (bool) +import Database.PostgreSQL.LibPQ (Oid(..)) + + +-- | A Postgresql type info +data PTI = PTI { oidOf :: Oid, arrayOIDOf :: Maybe Oid } + +abstime = PTI (Oid 702) (Just (Oid 1023)) +aclitem = PTI (Oid 1033) (Just (Oid 1034)) +bit = PTI (Oid 1560) (Just (Oid 1561)) +bool = PTI (Oid 16) (Just (Oid 1000)) +box = PTI (Oid 603) (Just (Oid 1020)) +bpchar = PTI (Oid 1042) (Just (Oid 1014)) +bytea = PTI (Oid 17) (Just (Oid 1001)) +char = PTI (Oid 18) (Just (Oid 1002)) +cid = PTI (Oid 29) (Just (Oid 1012)) +cidr = PTI (Oid 650) (Just (Oid 651)) +circle = PTI (Oid 718) (Just (Oid 719)) +cstring = PTI (Oid 2275) (Just (Oid 1263)) +date = PTI (Oid 1082) (Just (Oid 1182)) +daterange = PTI (Oid 3912) (Just (Oid 3913)) +float4 = PTI (Oid 700) (Just (Oid 1021)) +float8 = PTI (Oid 701) (Just (Oid 1022)) +gtsvector = PTI (Oid 3642) (Just (Oid 3644)) +inet = PTI (Oid 869) (Just (Oid 1041)) +int2 = PTI (Oid 21) (Just (Oid 1005)) +int2vector = PTI (Oid 22) (Just (Oid 1006)) +int4 = PTI (Oid 23) (Just (Oid 1007)) +int4range = PTI (Oid 3904) (Just (Oid 3905)) +int8 = PTI (Oid 20) (Just (Oid 1016)) +int8range = PTI (Oid 3926) (Just (Oid 3927)) +interval = PTI (Oid 1186) (Just (Oid 1187)) +json = PTI (Oid 114) (Just (Oid 199)) +line = PTI (Oid 628) (Just (Oid 629)) +lseg = PTI (Oid 601) (Just (Oid 1018)) +macaddr = PTI (Oid 829) (Just (Oid 1040)) +money = PTI (Oid 790) (Just (Oid 791)) +name = PTI (Oid 19) (Just (Oid 1003)) +numeric = PTI (Oid 1700) (Just (Oid 1231)) +numrange = PTI (Oid 3906) (Just (Oid 3907)) +oid = PTI (Oid 26) (Just (Oid 1028)) +oidvector = PTI (Oid 30) (Just (Oid 1013)) +path = PTI (Oid 602) (Just (Oid 1019)) +point = PTI (Oid 600) (Just (Oid 1017)) +polygon = PTI (Oid 604) (Just (Oid 1027)) +record = PTI (Oid 2249) (Just (Oid 2287)) +refcursor = PTI (Oid 1790) (Just (Oid 2201)) +regclass = PTI (Oid 2205) (Just (Oid 2210)) +regconfig = PTI (Oid 3734) (Just (Oid 3735)) +regdictionary = PTI (Oid 3769) (Just (Oid 3770)) +regoper = PTI (Oid 2203) (Just (Oid 2208)) +regoperator = PTI (Oid 2204) (Just (Oid 2209)) +regproc = PTI (Oid 24) (Just (Oid 1008)) +regprocedure = PTI (Oid 2202) (Just (Oid 2207)) +regtype = PTI (Oid 2206) (Just (Oid 2211)) +reltime = PTI (Oid 703) (Just (Oid 1024)) +text = PTI (Oid 25) (Just (Oid 1009)) +tid = PTI (Oid 27) (Just (Oid 1010)) +time = PTI (Oid 1083) (Just (Oid 1183)) +timestamp = PTI (Oid 1114) (Just (Oid 1115)) +timestamptz = PTI (Oid 1184) (Just (Oid 1185)) +timetz = PTI (Oid 1266) (Just (Oid 1270)) +tinterval = PTI (Oid 704) (Just (Oid 1025)) +tsquery = PTI (Oid 3615) (Just (Oid 3645)) +tsrange = PTI (Oid 3908) (Just (Oid 3909)) +tstzrange = PTI (Oid 3910) (Just (Oid 3911)) +tsvector = PTI (Oid 3614) (Just (Oid 3643)) +txid_snapshot = PTI (Oid 2970) (Just (Oid 2949)) +unknown = PTI (Oid 705) Nothing +uuid = PTI (Oid 2950) (Just (Oid 2951)) +varbit = PTI (Oid 1562) (Just (Oid 1563)) +varchar = PTI (Oid 1043) (Just (Oid 1015)) +void = PTI (Oid 2278) Nothing +xid = PTI (Oid 28) (Just (Oid 1011)) +xml = PTI (Oid 142) (Just (Oid 143)) + diff --git a/library/Hasql/Postgres/Parser.hs b/library/Hasql/Postgres/Parser.hs --- a/library/Hasql/Postgres/Parser.hs +++ b/library/Hasql/Postgres/Parser.hs @@ -1,14 +1,18 @@ module Hasql.Postgres.Parser where -import Hasql.Postgres.Prelude hiding (take) +import Hasql.Postgres.Prelude hiding (take, bool) import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString.Char8 hiding (double) import qualified Data.ByteString +import qualified Data.ByteString.Builder import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Base16 import qualified Data.Text import qualified Data.Text.Encoding import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding +import qualified Data.Text.Lazy.Builder +import qualified Data.Vector import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Database.PostgreSQL.LibPQ as PQ @@ -17,8 +21,18 @@ run :: ByteString -> P a -> Either Text a run input parser = - left fromString $ parseOnly (parser <* endOfInput) input - + 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 -- ** Parser ------------------------- @@ -46,16 +60,6 @@ ((string "true" <|> string "t" <|> string "True" <|> string "1") *> pure True) <|> ((string "false" <|> string "f" <|> string "False" <|> string "0") *> pure False) -byteString :: P ByteString -byteString = - labeling "byteString" $ - takeByteString >>= maybe (fail "Improper encoding") return . unsafePerformIO . PQ.unescapeBytea - -lazyByteString :: P LazyByteString -lazyByteString = - labeling "lazyByteString" $ - Data.ByteString.Lazy.fromStrict <$> byteString - utf8Char :: P Char utf8Char = labeling "utf8Char" $ @@ -144,7 +148,7 @@ do (p, h, m, s) <- timeZoneTuple return $! - minutesToTimeZone ((Hasql.Postgres.Prelude.bool negate id p) (60 * h + m)) + minutesToTimeZone ((if p then id else negate) (60 * h + m)) -- | -- Takes seconds in timezone into account. @@ -160,7 +164,7 @@ then \t -> timeToTimeOfDay $ timeOfDayToTime t - fromIntegral s else id composeTimezone p h m = - minutesToTimeZone ((Hasql.Postgres.Prelude.bool negate id p) (60 * h + m)) + minutesToTimeZone ((if p then id else negate) (60 * h + m)) utcTime :: P UTCTime utcTime = @@ -168,3 +172,193 @@ diffTime :: P DiffTime diffTime = timeOfDayToTime <$> timeOfDay + + +-- * Parsable +------------------------- + +class Parsable a where + -- | + -- @Maybe Char@ indicates which quote to expect for values, + -- which are quotable. + parser :: Maybe Char -> P a + +instance Parsable a => Parsable (Maybe a) where + parser q = + (string "NULL" *> pure Nothing) <|> + (Just <$> parser q) + +instance Parsable a => Parsable [a] where + parser _ = + char '{' *> sepBy (parser (Just '"')) (char ',' <* skipSpace) <* char '}' + +instance Parsable a => Parsable (Vector a) where + parser _ = + Data.Vector.fromList <$> parser $bottom + +instance Parsable Bool where + parser = + \case + Nothing -> bool + Just q -> char q *> bool <* char q + +instance Parsable Integer where + parser = const $ signed decimal + +instance Parsable Int where + parser = const $ signed decimal + +instance Parsable Int8 where + parser = const $ signed decimal + +instance Parsable Int16 where + parser = const $ signed decimal + +instance Parsable Int32 where + parser = const $ signed decimal + +instance Parsable Int64 where + parser = const $ signed decimal + +instance Parsable Word where + parser = const decimal + +instance Parsable Word8 where + parser = const decimal + +instance Parsable Word16 where + parser = const decimal + +instance Parsable Word32 where + parser = const decimal + +instance Parsable Word64 where + parser = const decimal + +instance Parsable Float where + parser = const float + +instance Parsable Double where + parser = const double + +instance Parsable Scientific where + parser = const A.scientific + +instance Parsable Day where + parser = + \case + Nothing -> day + Just q -> char q *> day <* char q + +instance Parsable TimeOfDay where + parser = + \case + Nothing -> timeOfDay + Just q -> char q *> timeOfDay <* char q + +instance Parsable LocalTime where + parser = + \case + Nothing -> localTime + Just q -> char q *> localTime <* char q + +instance Parsable ZonedTime where + parser = + \case + Nothing -> zonedTime + Just q -> char q *> zonedTime <* char q + +instance Parsable UTCTime where + parser = + \case + Nothing -> utcTime + Just q -> char q *> utcTime <* char q + +instance Parsable Char where + parser = + \case + Nothing -> utf8Char + Just q -> utf8Char <|> + (char q *> (escapedChar q <|> escapedChar '\\' <|> utf8Char) <* char q) + +instance Parsable Text where + parser = + \case + Nothing -> utf8Text + Just q -> Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText <$> quotedTextBuilder q + +instance Parsable LazyText where + parser = + \case + Nothing -> utf8LazyText + Just q -> Data.Text.Lazy.Builder.toLazyText <$> quotedTextBuilder q + +instance Parsable ByteString where + parser = + \case + Nothing -> Data.ByteString.Lazy.toStrict . Data.ByteString.Builder.toLazyByteString <$> + (string "\\x" *> hexByteStringBuilder) + Just q -> Data.ByteString.Lazy.toStrict . Data.ByteString.Builder.toLazyByteString <$> + (char q *> string "\\\\x" *> hexByteStringBuilder <* char q) + +instance Parsable LazyByteString where + parser = + \case + Nothing -> Data.ByteString.Builder.toLazyByteString <$> + (string "\\x" *> hexByteStringBuilder) + Just q -> Data.ByteString.Builder.toLazyByteString <$> + (char q *> string "\\\\x" *> hexByteStringBuilder <* char q) + + +-- * Unescaping +------------------------- + +escapedChar :: Char -> P Char +escapedChar c = + char '\\' *> char c + +unescapedWord8 :: P Word8 +unescapedWord8 = + labeling "unescapedWord8" $ do + w <- anyWord8 + if w == $([|fromIntegral $ ord '\\'|]) + then anyWord8 + else return w + +unescapedUTF8Char :: P Char +unescapedUTF8Char = + labeling "unescapedUTF8Char" $ + let loop attempt b = do + w <- unescapedWord8 + let b' = b <> Data.ByteString.singleton w + case Data.Text.Encoding.decodeUtf8' b' of + Right t -> return $ Data.Text.head t + Left _ -> + if attempt < 4 + then loop (succ attempt) b' + else fail "Failed to decode 4 bytes" + in loop 0 mempty + +quotedTextBuilder :: Char -> P Data.Text.Lazy.Builder.Builder +quotedTextBuilder q = + labeling "quotedTextBuilder" $ + char q *> loop + where + loop = + (char q *> pure mempty) <|> + ((<>) <$> (Data.Text.Lazy.Builder.singleton <$> unescapedUTF8Char) <*> loop) + +hexByteStringBuilder :: P Data.ByteString.Builder.Builder +hexByteStringBuilder = + labeling "hexByteStringBuilder" $ + loop + where + loop = + ((<>) <$> singleton <*> loop) <|> pure mempty + singleton = do + (c, r) <- fmap Data.ByteString.Base16.decode (take 2) + unless (Data.ByteString.null r) $ + fail $ "Invalid hex encoding: " <> show r + return $ Data.ByteString.Builder.byteString c + + diff --git a/library/Hasql/Postgres/Renderer.hs b/library/Hasql/Postgres/Renderer.hs --- a/library/Hasql/Postgres/Renderer.hs +++ b/library/Hasql/Postgres/Renderer.hs @@ -4,20 +4,28 @@ module Hasql.Postgres.Renderer where import Hasql.Postgres.Prelude -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as L +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.ByteString.Base16 as BB16 +import qualified Data.ByteString.Base16.Lazy as BB16L +import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import qualified Data.ByteString.Builder.Scientific +import qualified Data.Vector as Vector -- | A renderer of @a@. type R a = - a -> B.Builder + a -> BB.Builder run :: a -> R a -> ByteString run a f = - (L.toStrict . B.toLazyByteString . f) a + (BL.toStrict . BB.toLazyByteString . f) a -- ** Renderer @@ -25,35 +33,35 @@ ascii :: Show a => R a ascii = - B.string7 . show + BB.string7 . show -- *** strings ------------------------- char7 :: R Char = - B.char7 + BB.char7 char :: R Char = - B.charUtf8 + BB.charUtf8 string7 :: R String = - B.string7 + BB.string7 string :: R String = - B.string8 + BB.string8 byteString :: R ByteString = - B.byteString + BB.byteString lazyByteString :: R LazyByteString = - B.lazyByteString + BB.lazyByteString text :: R Text = - byteString . T.encodeUtf8 + T.encodeUtf8Builder lazyText :: R LazyText = - lazyByteString . LT.encodeUtf8 + TL.encodeUtf8Builder -- *** enumerations @@ -63,43 +71,43 @@ \b -> if b then word8 1 else word8 0 word8 :: R Word8 = - B.word8Dec + BB.word8Dec word16 :: R Word16 = - B.word16Dec + BB.word16Dec word32 :: R Word32 = - B.word32Dec + BB.word32Dec word64 :: R Word64 = - B.word64Dec + BB.word64Dec word :: R Word = - B.wordDec + BB.wordDec int8 :: R Int8 = - B.int8Dec + BB.int8Dec int16 :: R Int16 = - B.int16Dec + BB.int16Dec int32 :: R Int32 = - B.int32Dec + BB.int32Dec int64 :: R Int64 = - B.int64Dec + BB.int64Dec int :: R Int = - B.intDec + BB.intDec integer :: R Integer = - B.integerDec + BB.integerDec paddedInt :: Int -> R Int paddedInt padding n = if padding <= width then int n - else mconcat (replicate (padding - width) (B.char7 '0')) <> int n + else mconcat (replicate (padding - width) (BB.char7 '0')) <> int n where width = fromIntegral (succ (floor (logBase 10 (fromIntegral n))) :: Integer) @@ -108,47 +116,197 @@ ------------------------- float :: R Float = - B.floatDec + BB.floatDec double :: R Double = - B.doubleDec + BB.doubleDec pico :: R Pico = - B.string7 . showFixed True + BB.string7 . showFixed True scientific :: R Scientific = Data.ByteString.Builder.Scientific.scientificBuilder + -- *** time ------------------------- day :: R Day = - B.string7 . formatTime defaultTimeLocale (iso8601DateFormat Nothing) + BB.string7 . formatTime defaultTimeLocale (iso8601DateFormat Nothing) timeOfDay :: R TimeOfDay = - B.string7 . formatTime defaultTimeLocale "%T%Q" + BB.string7 . formatTime defaultTimeLocale "%T%Q" localTime :: R LocalTime = - B.string7 . formatTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q")) + BB.string7 . formatTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q")) timeZone :: R TimeZone = \(TimeZone t _ _) -> if t < 0 - then B.char7 '-' <> uncurry hm (divMod (negate t) 60) - else B.char7 '+' <> uncurry hm (divMod t 60) + then BB.char7 '-' <> uncurry hm (divMod (negate t) 60) + else BB.char7 '+' <> uncurry hm (divMod t 60) where hm h m = - paddedInt 2 h <> B.char7 ':' <> paddedInt 2 m + paddedInt 2 h <> BB.char7 ':' <> paddedInt 2 m zonedTime :: R ZonedTime = \(ZonedTime lt tz) -> localTime lt <> timeZone tz utcTime :: R UTCTime = - B.string7 . formatTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q")) + BB.string7 . formatTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q")) diffTime :: R DiffTime = pico . fromRational . toRational nominalDiffTime :: R NominalDiffTime = pico . fromRational . toRational + + +-- * Renderable +------------------------- + +class Renderable a where + -- | + -- The boolean indicates a quoted mode. + renderer :: Maybe Char -> R a + +instance Renderable a => Renderable (Maybe a) where + renderer q v = + maybe (string7 "NULL") (renderer q) v + +instance Renderable a => Renderable [a] where + renderer _ v = + execWriter $ do + tell $ char7 '{' + tell $ mconcat $ intersperse (string7 ", ") $ map (renderer (Just '"')) v + tell $ char7 '}' + +instance Renderable a => Renderable (Vector a) where + renderer _ = + renderer $bottom . Vector.toList + +instance Renderable Bool where + renderer q = + maybe id quoting q . \case + True -> char7 't' + False -> char7 'f' + +instance Renderable Int where + renderer _ = + BB.intDec + +instance Renderable Int8 where + renderer _ = + BB.int8Dec + +instance Renderable Int16 where + renderer _ = + BB.int16Dec + +instance Renderable Int32 where + renderer _ = + BB.int32Dec + +instance Renderable Int64 where + renderer _ = + BB.int64Dec + +instance Renderable Integer where + renderer _ = + BB.integerDec + +instance Renderable Word where + renderer _ = + BB.wordDec + +instance Renderable Word8 where + renderer _ = + BB.word8Dec + +instance Renderable Word16 where + renderer _ = + BB.word16Dec + +instance Renderable Word32 where + renderer _ = + BB.word32Dec + +instance Renderable Word64 where + renderer _ = + BB.word64Dec + +instance Renderable Float where + renderer _ = + BB.floatDec + +instance Renderable Double where + renderer _ = + BB.doubleDec + +instance Renderable Scientific where + renderer _ = + Data.ByteString.Builder.Scientific.scientificBuilder + +instance Renderable Day where + renderer q = + maybe id quoting q . day + +instance Renderable TimeOfDay where + renderer q = + maybe id quoting q . timeOfDay + +instance Renderable LocalTime where + renderer q = + maybe id quoting q . localTime + +instance Renderable ZonedTime where + renderer q = + maybe id quoting q . zonedTime + +instance Renderable UTCTime where + renderer q = + maybe id quoting q . utcTime + +instance Renderable Char where + renderer q = + renderer Nothing . T.singleton + +instance Renderable Text where + renderer = + maybe T.encodeUtf8Builder (\q -> quoting q . escaping q . T.encodeUtf8) + where + escaping q = + BC.foldr (mappend . escapedChar8 q) mempty + +instance Renderable LazyText where + renderer q = + maybe TL.encodeUtf8Builder (\qc -> quoting qc . escaping qc . TL.encodeUtf8) q + where + escaping q = + BLC.foldr (mappend . escapedChar8 q) mempty + +instance Renderable ByteString where + renderer = + (. encode) . maybe (BB.string7 "\\x" <>) (\q -> quoting q . (BB.string7 "\\\\x" <>)) + where + encode = BB.byteString . BB16.encode + +instance Renderable LazyByteString where + renderer = + (. encode) . maybe (BB.string7 "\\x" <>) (\q -> quoting q . (BB.string7 "\\\\x" <>)) + where + encode = BB.lazyByteString . BB16L.encode + + +-- ** Helpers +------------------------- + +quoting :: Char -> R BB.Builder +quoting q = + (char7 q <>) . (<> char7 q) + +escapedChar8 :: Char -> R Char +escapedChar8 q c = + (if c == q || c == '\\' then (char7 '\\' <>) else id) $ BB.char8 c + diff --git a/library/Hasql/Postgres/Statement.hs b/library/Hasql/Postgres/Statement.hs --- a/library/Hasql/Postgres/Statement.hs +++ b/library/Hasql/Postgres/Statement.hs @@ -2,7 +2,6 @@ import Hasql.Postgres.Prelude import qualified Database.PostgreSQL.LibPQ as L -import qualified Hasql.Postgres.OID as OID import qualified Hasql.Postgres.Renderer as Renderer diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -21,6 +21,7 @@ import qualified Hasql as H import qualified Hasql.Postgres as H import qualified Data.Scientific as Scientific +import qualified Data.Vector as Vector type Text = Data.Text.Text @@ -116,11 +117,76 @@ list $ [q|select oid, typname from pg_type|] liftIO $ assertNotEqual [] r + +-- * Mappings +------------------------- + test_mappingOfMaybe = session1 $ do validMappingSession (Just '!') validMappingSession (Nothing :: Maybe Bool) +test_mappingOfVector1 = + session1 $ do + validMappingSession v1 + validMappingSession v2 + where + v1 = Vector.fromList [v2, v2] + v2 = Vector.fromList [Just 'a', Nothing, Just 'b'] + +test_mappingOfVector2 = + session1 $ do + validMappingSession v1 + validMappingSession v2 + where + v1 = Vector.fromList [v2, v2] + v2 = Vector.fromList [Just (1 :: Int), Just 2, Nothing] + +test_mappingOfVector3 = + session1 $ do + validMappingSession v1 + where + v1 = + Vector.fromList + [ + " 'a' \"b\" \\c\\ " :: Text + ] + +test_mappingOfVector4 = + assertEqual (Just (Identity v1)) =<< do + session1 $ tx Nothing $ do + unit $ [q|DROP TABLE IF EXISTS a|] + unit $ [q|CREATE TABLE a ("v" char[][])|] + unit $ [q|INSERT INTO a (v) VALUES (?)|] v1 + single $ [q|SELECT v FROM a|] + where + v1 = + Vector.fromList + [ + Vector.fromList [Just 'a', Just 'b'], + Vector.fromList [Nothing, Just 'c'] + ] + +test_mappingOfVector5 = + session1 $ do + validMappingSession v1 + where + v1 = + Vector.fromList + [ + " 'a' \"b\" \\c\\ ф" :: ByteString + ] + +prop_mappingOfVectorOverByteString (list :: [ByteString]) = + mappingProp v + where + v = Vector.fromList list + +prop_mappingOfVectorOverLazyByteString (list :: [LazyByteString]) = + mappingProp v + where + v = Vector.fromList list + test_mappingOfBool = session1 $ do validMappingSession True @@ -133,73 +199,73 @@ -- Postgres does not allow the '/NUL' character in text data prop_mappingOfChar (v :: Char) = (v /= '\NUL') ==> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v -- Postgres does not allow the '/NUL' character in text data prop_mappingOfText (v :: Text) = (isNothing $ Data.Text.find (== '\NUL') v) ==> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfLazyText (v :: LazyText) = (isNothing $ Data.Text.Lazy.find (== '\NUL') v) ==> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfByteString (v :: ByteString) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfLazyByteString (v :: LazyByteString) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfInt (v :: Int) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfInt8 (v :: Int8) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfInt16 (v :: Int16) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfInt32 (v :: Int32) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfInt64 (v :: Int64) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfWord (v :: Word) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfWord8 (v :: Word8) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfWord16 (v :: Word16) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfWord32 (v :: Word32) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfWord64 (v :: Word64) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfFloat (v :: Float) = - floatEq v (fromJust $ unsafePerformIO $ session1 $ selectSelf v) + floatEqProp v (fromJust $ unsafePerformIO $ session1 $ selectSelf v) prop_mappingOfDouble (v :: Double) = - floatEq v (fromJust $ unsafePerformIO $ session1 $ selectSelf v) + floatEqProp v (fromJust $ unsafePerformIO $ session1 $ selectSelf v) prop_mappingOfScientific = forAll scientificGen $ \v -> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfDay (v :: Day) = - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfTimeOfDay (v :: TimeOfDay) = forAll microsTimeOfDayGen $ \v -> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfLocalTime = forAll microsLocalTimeGen $ \v -> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v prop_mappingOfZonedTime = forAll gen $ \v -> @@ -214,10 +280,17 @@ prop_mappingOfUTCTime = forAll gen $ \v -> - Just v === do unsafePerformIO $ session1 $ selectSelf v + mappingProp v where gen = UTCTime <$> arbitrary <*> microsDiffTimeGen + +-- * Helpers +------------------------- + +-- ** Generators +------------------------- + scientificGen :: Gen Scientific scientificGen = Scientific.scientific <$> arbitrary <*> arbitrary @@ -234,8 +307,11 @@ microsDiffTimeGen = do fmap picosecondsToDiffTime $ fmap (* (10^6)) $ choose (0, (10^6)*24*60*60) +-- ** Session +------------------------- + selectSelf :: - Backend.Mapping Postgres a => Typeable a => + Backend.Mapping Postgres a => a -> Session Postgres IO (Maybe a) selectSelf v = tx Nothing $ (fmap . fmap) runIdentity $ single $ [q| SELECT ? |] v @@ -253,9 +329,16 @@ backendSettings = Postgres "localhost" 5432 "postgres" "" "postgres" poolSettings = fromJust $ sessionSettings 6 30 -floatEq :: RealFrac a => Show a => a -> a -> Property -floatEq a b = +-- ** Property +------------------------- + +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 / 100 + +mappingProp :: (Show a, Eq a, Backend.Mapping Postgres a) => a -> Property +mappingProp v = + Just v === do unsafePerformIO $ session1 $ selectSelf v