hasql-postgres 0.1.1 → 0.1.2
raw patch · 10 files changed
+749/−272 lines, 10 filesdep +base16-bytestringdep +template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: base16-bytestring, template-haskell
API changes (from Hackage documentation)
+ Hasql.Postgres: instance (Mapping Postgres a, Renderable a, Parsable a, OIDMapping a) => Mapping Postgres (Vector a)
+ Hasql.Postgres: instance (Mapping Postgres a, Renderable a, Parsable a, OIDMapping a) => Mapping Postgres [a]
Files
- hasql-postgres.cabal +16/−3
- library-tests/Main.hs +1/−0
- library/Hasql/Postgres.hs +80/−134
- library/Hasql/Postgres/OID.hs +0/−58
- library/Hasql/Postgres/OIDMapping.hs +63/−0
- library/Hasql/Postgres/PTI.hs +78/−0
- library/Hasql/Postgres/Parser.hs +209/−15
- library/Hasql/Postgres/Renderer.hs +194/−36
- library/Hasql/Postgres/Statement.hs +0/−1
- tests/Main.hs +108/−25
hasql-postgres.cabal view
@@ -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 + <http://hackage.haskell.org/package/hasql the \"hasql\" library>.+ .+ 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.*,
library-tests/Main.hs view
@@ -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 =
library/Hasql/Postgres.hs view
@@ -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)+ |]
− library/Hasql/Postgres/OID.hs
@@ -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
+ library/Hasql/Postgres/OIDMapping.hs view
@@ -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))+ |]
+ library/Hasql/Postgres/PTI.hs view
@@ -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))+
library/Hasql/Postgres/Parser.hs view
@@ -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++
library/Hasql/Postgres/Renderer.hs view
@@ -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+
library/Hasql/Postgres/Statement.hs view
@@ -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
tests/Main.hs view
@@ -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