hasql-postgres 0.1.3 → 0.2.0
raw patch · 13 files changed
+595/−1001 lines, 13 filesdep +postgresql-binarydep +uuiddep −Decimaldep −base16-bytestringdep −mmorphdep ~hasqldep ~timePVP ok
version bump matches the API change (PVP)
Dependencies added: postgresql-binary, uuid
Dependencies removed: Decimal, base16-bytestring, mmorph, utf8-string
Dependency ranges changed: hasql, time
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]
- Hasql.Postgres: instance Mapping Postgres ZonedTime
- Hasql.Postgres: instance Mapping Postgres a => Mapping Postgres (Maybe a)
+ Hasql.Postgres: instance (Mapping a, ArrayMapping a) => Mapping Postgres (Vector a)
+ Hasql.Postgres: instance (Mapping a, ArrayMapping a) => Mapping Postgres [a]
+ Hasql.Postgres: instance Mapping Postgres (TimeOfDay, TimeZone)
+ Hasql.Postgres: instance Mapping Postgres DiffTime
+ Hasql.Postgres: instance Mapping Postgres UUID
+ Hasql.Postgres: instance Mapping a => Mapping Postgres (Maybe a)
Files
- hasql-postgres.cabal +21/−21
- library-tests/Main.hs +0/−2
- library/Hasql/Postgres.hs +264/−91
- library/Hasql/Postgres/Connector.hs +13/−9
- library/Hasql/Postgres/Mapping.hs +166/−0
- library/Hasql/Postgres/OIDMapping.hs +0/−63
- library/Hasql/Postgres/PTI.hs +85/−70
- library/Hasql/Postgres/Parser.hs +0/−364
- library/Hasql/Postgres/Prelude.hs +9/−9
- library/Hasql/Postgres/Renderer.hs +0/−312
- library/Hasql/Postgres/Statement.hs +12/−11
- library/Hasql/Postgres/StatementPreparer.hs +4/−2
- tests/Main.hs +21/−47
hasql-postgres.cabal view
@@ -1,12 +1,18 @@ name: hasql-postgres version:- 0.1.3+ 0.2.0 synopsis: A "PostgreSQL" backend for the "hasql" library description: This library provides a \"PostgreSQL\" driver for <http://hackage.haskell.org/package/hasql the "hasql" library>.+ .+ According to the included benchmarks,+ it performs up to 2.5x faster than \"postgresql-simple\" and+ up to 8x faster than \"HDBC\".+ You can read up+ <http://nikita-volkov.github.io/hasql-benchmarks/ a post with analysis of those benchmarks>. category: Database homepage:@@ -47,12 +53,10 @@ Haskell2010 other-modules: Hasql.Postgres.Prelude- Hasql.Postgres.Renderer Hasql.Postgres.ErrorCode Hasql.Postgres.PTI- Hasql.Postgres.OIDMapping+ Hasql.Postgres.Mapping Hasql.Postgres.Statement- Hasql.Postgres.Parser Hasql.Postgres.StatementPreparer Hasql.Postgres.TemplateConverter Hasql.Postgres.TemplateConverter.Parser@@ -68,19 +72,18 @@ attoparsec == 0.12.*, -- database: hasql-backend == 0.1.*,+ postgresql-binary == 0.1.*, postgresql-libpq == 0.9.*, -- data:- base16-bytestring == 0.1.*,+ uuid == 1.3.*, vector == 0.10.*,- old-locale == 1.0.*,- time == 1.4.*,+ time >= 1.4 && < 1.6, hashtables == 1.1.*, scientific == 0.3.*, text >= 1 && < 1.3, bytestring >= 0.10.4.0 && < 0.11, hashable == 1.2.*, -- control:- mmorph == 1.0.*, list-t >= 0.2.3 && < 0.3, -- errors: loch-th == 0.2.*,@@ -118,22 +121,19 @@ -- parsers: attoparsec == 0.12.*, -- database:- hasql == 0.1.*,+ hasql >= 0.1.4 && < 0.2,+ postgresql-binary == 0.1.*, postgresql-libpq == 0.9.*, -- data:- base16-bytestring == 0.1.*,+ uuid == 1.3.*, vector == 0.10.*,- utf8-string >= 0.3.8 && < 0.4,- old-locale == 1.0.*,- time == 1.4.*,+ time >= 1.4 && < 1.6, hashtables == 1.1.*,- Decimal == 0.4.*, scientific == 0.3.*, text >= 1 && < 1.3, bytestring >= 0.10.4.0 && < 0.11, hashable == 1.2.*, -- control:- mmorph == 1.0.*, list-t >= 0.2.3 && < 0.3, -- errors: loch-th == 0.2.*,@@ -162,7 +162,7 @@ build-depends: hasql-postgres, hasql-backend,- hasql == 0.1.*,+ hasql >= 0.1.4 && < 0.2, -- testing: HTF == 0.12.*, quickcheck-instances == 0.3.*,@@ -174,7 +174,7 @@ -- data: vector == 0.10.*, old-locale == 1.0.*,- time == 1.4.*,+ time >= 1.4 && < 1.6, scientific == 0.3.*, text >= 1 && < 1.3, bytestring >= 0.10.4.0 && < 0.11,@@ -208,7 +208,7 @@ postgresql-simple == 0.4.*, hasql-postgres, hasql-backend,- hasql == 0.1.*,+ hasql >= 0.1.4 && < 0.2, -- random: QuickCheck == 2.7.*, quickcheck-instances == 0.3.*,@@ -216,7 +216,7 @@ criterion-plus == 0.1.*, -- data: vector == 0.10.*,- time == 1.4.*,+ time >= 1.4 && < 1.6, text >= 1 && < 1.3, scientific == 0.3.*, -- general:@@ -250,13 +250,13 @@ postgresql-simple == 0.4.*, hasql-postgres, hasql-backend,- hasql == 0.1.*,+ hasql >= 0.1.4 && < 0.2, -- random: QuickCheck == 2.7.*, quickcheck-instances == 0.3.*, -- data: vector == 0.10.*,- time == 1.4.*,+ time >= 1.4 && < 1.6, text >= 1 && < 1.3, scientific == 0.3.*, -- general:
library-tests/Main.hs view
@@ -4,8 +4,6 @@ import Test.Framework 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
@@ -1,3 +1,16 @@+-- |+-- This module contains everything required +-- to use \"hasql\" with Postgres.+-- For information on how it should be used consult the \"hasql\" docs.+-- +-- Please note that there is a few limitations inflicted by Postgres,+-- encoding which in the type system would seriously burden the API,+-- so it was decided to make it the user's responsibility +-- to make sure that certain conditions are satisfied during the runtime.+-- Particularly this concerns the 'Backend.Mapping' instances of +-- @Maybe@, @[]@ and @Vector@.+-- For details consult the docs on those instances.+-- module Hasql.Postgres ( Postgres(..), @@ -13,12 +26,12 @@ import qualified Hasql.Postgres.Statement as Statement import qualified Hasql.Postgres.StatementPreparer as StatementPreparer 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.OIDMapping as OIDMapping+import qualified Hasql.Postgres.PTI as PTI+import qualified Hasql.Postgres.Mapping as Mapping+import qualified Language.Haskell.TH as TH+import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Data.Text.Encoding as Text import qualified ListT-import qualified Language.Haskell.TH as TH -- |@@ -59,6 +72,7 @@ execute s c = ResultHandler.unit =<< execute (liftStatement s) c executeAndGetMatrix s c =+ {-# SCC "executeAndGetMatrix" #-} unsafeCoerce . ResultHandler.rowsVector =<< execute (liftStatement s) c executeAndStream s c = do@@ -76,7 +90,7 @@ counterM <- readIORef (transactionState c) counter <- maybe (throwIO Backend.NotInTransaction) return counterM writeIORef (transactionState c) (Just (succ counter))- return $ Renderer.run counter $ \n -> Renderer.char 'v' <> Renderer.word n+ return $ fromString $ 'v' : show counter declareCursor = do name <- nextName@@ -89,9 +103,9 @@ executeAndCountEffects s c = do b <- ResultHandler.rowsAffected =<< execute (liftStatement s) c- case Parser.run b Parser.unsignedIntegral of+ case Atto.parseOnly (Atto.decimal <* Atto.endOfInput) b of Left m -> - throwIO $ Backend.UnexpectedResult m+ throwIO $ Backend.UnexpectedResult (fromString m) Right r -> return r beginTransaction (isolation, write) c = @@ -123,10 +137,10 @@ True -> do let (tl, vl) = unzip params key <- StatementPreparer.prepare convertedTemplate tl (preparer c)- PQ.execPrepared (connection c) key vl PQ.Text+ PQ.execPrepared (connection c) key vl PQ.Binary False -> do let params' = map (\(t, v) -> (\(vb, vf) -> (t, vb, vf)) <$> v) params- PQ.execParams (connection c) convertedTemplate params' PQ.Text+ PQ.execParams (connection c) convertedTemplate params' PQ.Binary convertTemplate :: ByteString -> IO ByteString convertTemplate t =@@ -142,96 +156,255 @@ -- * Mappings ----------------------------- ** Helpers+-- Not using TH to generate instances+-- to be able to document them. ------------------------- --- |--- Make a 'renderValue' function.-{-# INLINE mkRenderValue #-}-mkRenderValue :: PQ.Format -> PQ.Oid -> Renderer.R a -> (a -> Backend.StatementArgument Postgres)-mkRenderValue f o r a =- StatementArgument (o, Just (Renderer.run a r, f)) -{-# INLINE mkParseResult #-}-mkParseResult :: Parser.P a -> (Backend.Result Postgres -> Either Text a)-mkParseResult p (Result r) =- do- r' <- maybe (Left "Null result") Right r- left (\t -> t <> "; Input: " <> (fromString . show) r') $ - Parser.run r' p---- ** Instances--------------------------+{-# INLINE renderValueUsingMapping #-}+renderValueUsingMapping :: Mapping.Mapping a => a -> Backend.StatementArgument Postgres+renderValueUsingMapping x = + StatementArgument (oid, (,) <$> value <*> pure PQ.Binary)+ where+ oid = PTI.oidPQ $ Mapping.oid x+ value = Mapping.encode x --- | 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+{-# INLINE parseResultUsingMapping #-}+parseResultUsingMapping :: Mapping.Mapping a => Backend.Result Postgres -> Either Text a+parseResultUsingMapping (Result x) = + Mapping.decode x -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 the same type as the underlying value, +-- encoding 'Nothing' as /NULL/.+-- +-- /LIMITATION/+-- +-- Multilevel 'Maybe's are not supported.+-- E.g., a value @Just Nothing@ of type @(Maybe (Maybe a))@ +-- will be encoded the same way as @Nothing@.+instance Mapping.Mapping a => Backend.Mapping Postgres (Maybe a) where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping -- | -- Maps to Postgres arrays. -- --- Please note that since @String@ is just an alias to @[Char]@,+-- /LIMITATION 1/+-- +-- In multidimensional lists all rows of a dimension must have the same length.+-- +-- E.g., the following is a corrupt value:+-- +-- > [[1,2], [3]]+-- +-- The following is a valid one:+-- +-- > [[1,2], [3,4], [5,6]]+-- +-- /LIMITATION 2/+-- +-- 'Maybe' cannot be used to wrap an intermediate level in a multidimensional array.+-- +-- E.g., the following is a corrupt type:+-- +-- > [Maybe [a]]+-- +-- However, both the first level list and the value are allowed to be wrapped in 'Maybe'.+-- So the following is a valid type:+-- +-- > Maybe [[[Maybe a]]]+-- +-- /NOTICE/+-- +-- Also, 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)+-- So if you want to map to a textual type use 'Text' instead.+-- +instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Backend.Mapping Postgres [a] where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping -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)- |]+-- |+-- Maps to Postgres' arrays.+-- +-- Same rules as for the list instance apply. +-- Consult its docs for details.+instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Backend.Mapping Postgres (Vector a) where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int8@.+instance Backend.Mapping Postgres Int where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int2@.+instance Backend.Mapping Postgres Int8 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int2@.+instance Backend.Mapping Postgres Int16 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int4@.+instance Backend.Mapping Postgres Int32 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int8@.+instance Backend.Mapping Postgres Int64 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int8@.+instance Backend.Mapping Postgres Word where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int2@.+instance Backend.Mapping Postgres Word8 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int2@.+instance Backend.Mapping Postgres Word16 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int4@.+instance Backend.Mapping Postgres Word32 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @int8@.+instance Backend.Mapping Postgres Word64 where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @float4@.+instance Backend.Mapping Postgres Float where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @float8@.+instance Backend.Mapping Postgres Double where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @numeric@.+instance Backend.Mapping Postgres Scientific where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @date@.+instance Backend.Mapping Postgres Day where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @time@.+instance Backend.Mapping Postgres TimeOfDay where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @timetz@.+-- +-- Unlike with @timestamptz@, +-- Postgres does store the timezone information for @timetz@.+-- However the \"time\" library does not contain any composite type,+-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'+-- to represent a value on the Haskell's side.+instance Backend.Mapping Postgres (TimeOfDay, TimeZone) where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @timestamptz@.+-- +-- /NOTICE/+-- +-- Postgres does not store the timezone information of @timestamptz@.+-- Instead it stores a UTC value and silently interconverts +-- the incoming and outgoing values into a local time +-- of the client application according to client application's timezone.+-- +-- This is a notoriously questionable design decision by the Postgres authors.+-- This is why it is instead recommended to use @timestamp@ and 'UTCTime',+-- while manually handling the timezone conversions on the application side.+instance Backend.Mapping Postgres LocalTime where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @timestamp@.+instance Backend.Mapping Postgres UTCTime where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @interval@.+instance Backend.Mapping Postgres DiffTime where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @char@.+-- Note that it supports UTF-8 values.+instance Backend.Mapping Postgres Char where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @text@.+instance Backend.Mapping Postgres Text where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @text@.+instance Backend.Mapping Postgres LazyText where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @bytea@.+instance Backend.Mapping Postgres ByteString where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @bytea@.+instance Backend.Mapping Postgres LazyByteString where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @bool@.+instance Backend.Mapping Postgres Bool where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping++-- |+-- Maps to @uuid@.+instance Backend.Mapping Postgres UUID where+ renderValue = renderValueUsingMapping+ parseResult = parseResultUsingMapping+
library/Hasql/Postgres/Connector.hs view
@@ -4,7 +4,10 @@ import Hasql.Postgres.Prelude hiding (Error) import qualified Database.PostgreSQL.LibPQ as L-import qualified Hasql.Postgres.Renderer as Renderer+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Encoding as TE data Settings =@@ -35,7 +38,7 @@ open :: Settings -> ExceptT Error IO L.Connection open s = do- c <- lift $ L.connectdb (Renderer.run s settingsRenderer)+ c <- lift $ L.connectdb (settingsBS s) do s <- lift $ L.status c when (s /= L.ConnectionOk) $ @@ -54,15 +57,16 @@ return c -settingsRenderer :: Renderer.R Settings-settingsRenderer s =+settingsBS :: Settings -> ByteString+settingsBS s =+ BL.toStrict $ BB.toLazyByteString $ mconcat $ intersperse " " args where args = [- "host=" <> Renderer.byteString (host s),- "port=" <> Renderer.word16 (port s),- "user=" <> Renderer.text (user s),- "password=" <> Renderer.text (password s),- "dbname=" <> Renderer.text (database s)+ "host=" <> BB.byteString (host s),+ "port=" <> BB.word16Dec (port s),+ "user=" <> TE.encodeUtf8Builder (user s),+ "password=" <> TE.encodeUtf8Builder (password s),+ "dbname=" <> TE.encodeUtf8Builder (database s) ]
+ library/Hasql/Postgres/Mapping.hs view
@@ -0,0 +1,166 @@+-- |+-- Internal mappings.+module Hasql.Postgres.Mapping where++import Hasql.Postgres.Prelude hiding (bool)+import qualified Language.Haskell.TH as TH+import qualified Hasql.Postgres.PTI as PTI+import qualified Data.Vector as V+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy as TL+import qualified PostgreSQLBinary.Array as Array+import qualified PostgreSQLBinary.Encoder as Encoder+import qualified PostgreSQLBinary.Decoder as Decoder+++type Value =+ Maybe ByteString++-- |+-- A final value level mapping.+class Mapping a where+ oid :: a -> PTI.OID+ encode :: a -> Value+ decode :: Value -> Either Text a++-- |+-- A mapping for construction of array values.+class ArrayMapping a where+ arrayOID :: a -> PTI.OID+ arrayEncode :: a -> Array.Data+ arrayDecode :: Array.Data -> Either Text a+++instance Mapping a => Mapping (Maybe a) where+ oid = + const $ oid (undefined :: a)+ encode = + join . traverse encode+ decode = + maybe (return Nothing) (fmap Just . decode . Just)++instance (ArrayMapping a, Mapping a) => ArrayMapping (Maybe a) where+ arrayOID =+ const $ arrayOID (undefined :: a)+ arrayEncode =+ \case+ Nothing -> + Array.fromSingleton Nothing True (PTI.oidWord32 (oid (undefined :: a)))+ Just x ->+ setNullable True $ arrayEncode x+ where+ setNullable x (dl, vl, _, oid) = (dl, vl, True, oid)+ arrayDecode =+ \case+ (_, [x], _, _) -> decode x+ x -> Left $ "Array data doesn't match the 'Maybe' type: " <> (fromString . show) x+++instance (Mapping a, ArrayMapping a) => Mapping [a] where+ oid = + arrayOID+ encode = + Just . Encoder.array . arrayEncode+ decode x = + do+ b <- maybe (Left "NULL input") return x+ a <- Decoder.array b+ arrayDecode a++instance (Mapping a, ArrayMapping a) => ArrayMapping [a] where+ arrayOID =+ const $ arrayOID (undefined :: a)+ arrayEncode =+ \case+ [] -> ([(0, 1)], [], False, PTI.oidWord32 $ oid (undefined :: a))+ x -> Array.fromListUnsafe . map arrayEncode $ x+ arrayDecode x =+ traverse arrayDecode $ Array.elements x+++instance (Mapping a, ArrayMapping a) => Mapping (Vector a) where+ oid =+ arrayOID+ encode = + Just . Encoder.array . arrayEncode+ decode x = + do+ b <- maybe (Left "NULL input") return x+ a <- Decoder.array b+ arrayDecode a++instance (Mapping a, ArrayMapping a) => ArrayMapping (Vector a) where+ arrayOID =+ const $ arrayOID (undefined :: a)+ arrayEncode =+ arrayEncode . V.toList+ arrayDecode =+ fmap V.fromList . arrayDecode+++let+ settings =+ [ + ([t|Int|], [|PTI.int8|], [|Encoder.int8 . Left . fromIntegral|], [|Decoder.int|]),+ ([t|Int8|], [|PTI.int2|], [|Encoder.int2 . Left . fromIntegral|], [|Decoder.int|]),+ ([t|Int16|], [|PTI.int2|], [|Encoder.int2 . Left|], [|Decoder.int|]),+ ([t|Int32|], [|PTI.int4|], [|Encoder.int4 . Left|], [|Decoder.int|]),+ ([t|Int64|], [|PTI.int8|], [|Encoder.int8 . Left|], [|Decoder.int|]),+ ([t|Word|], [|PTI.int8|], [|Encoder.int8 . Right . fromIntegral|], [|Decoder.int|]),+ ([t|Word8|], [|PTI.int2|], [|Encoder.int2 . Right . fromIntegral|], [|Decoder.int|]),+ ([t|Word16|], [|PTI.int2|], [|Encoder.int2 . Right|], [|Decoder.int|]),+ ([t|Word32|], [|PTI.int4|], [|Encoder.int4 . Right|], [|Decoder.int|]),+ ([t|Word64|], [|PTI.int8|], [|Encoder.int8 . Right|], [|Decoder.int|]),+ ([t|Float|], [|PTI.float4|], [|Encoder.float4|], [|Decoder.float4|]),+ ([t|Double|], [|PTI.float8|], [|Encoder.float8|], [|Decoder.float8|]),+ ([t|Scientific|], [|PTI.numeric|], [|Encoder.numeric|], [|Decoder.numeric|]),+ ([t|Day|], [|PTI.date|], [|Encoder.date|], [|Decoder.date|]),+ ([t|TimeOfDay|], [|PTI.time|], [|Encoder.time|], [|Decoder.time|]),+ ([t|(TimeOfDay, TimeZone)|], [|PTI.timetz|], [|Encoder.timetz|], [|Decoder.timetz|]),+ ([t|UTCTime|], [|PTI.timestamp|], [|Encoder.timestamp|], [|Decoder.timestamp|]),+ ([t|LocalTime|], [|PTI.timestamptz|], [|Encoder.timestamptz|], [|Decoder.timestamptz|]),+ ([t|DiffTime|], [|PTI.interval|], [|Encoder.interval|], [|Decoder.interval|]),+ ([t|Char|], [|PTI.text|], [|Encoder.char|], [|Decoder.char|]),+ ([t|Text|], [|PTI.text|], [|Encoder.text . Left|], [|Decoder.text|]),+ ([t|LazyText|], [|PTI.text|], [|Encoder.text . Right|], [|fmap TL.fromStrict . Decoder.text|]),+ ([t|ByteString|], [|PTI.bytea|], [|Encoder.bytea . Left|], [|Decoder.bytea|]),+ ([t|LazyByteString|], [|PTI.bytea|], [|Encoder.bytea . Right|], [|fmap BL.fromStrict . Decoder.bytea|]),+ ([t|Bool|], [|PTI.bool|], [|Encoder.bool|], [|Decoder.bool|]),+ ([t|UUID|], [|PTI.uuid|], [|Encoder.uuid|], [|Decoder.uuid|])+ ]+ in+ fmap concat $ forM settings $ \(t, pti, encoder, decoder) ->+ [d|++ instance Mapping $t where+ {-# INLINE oid #-}+ oid =+ const $ PTI.ptiOID $pti+ {-# INLINE encode #-}+ encode =+ Just . $encoder+ {-# INLINE decode #-}+ decode x =+ do+ b <- maybe (Left "NULL input") return x+ $decoder b++ instance ArrayMapping $t where+ {-# INLINE arrayOID #-}+ arrayOID =+ const $ fromMaybe ($bug "No array OID") $ PTI.ptiArrayOID $pti+ {-# INLINE arrayEncode #-}+ arrayEncode x =+ Array.fromSingleton (Just ($encoder x))+ (False)+ (PTI.oidWord32 (PTI.ptiOID $pti))+ {-# INLINE arrayDecode #-}+ arrayDecode =+ \case+ (_, [x], _, _) -> decode x+ x -> Left $ "Array data doesn't match the '" <> + $(t >>= TH.stringE . show) <> "' type: " <> + (fromString . show) x++ |]+
− library/Hasql/Postgres/OIDMapping.hs
@@ -1,63 +0,0 @@-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
@@ -1,78 +1,93 @@ module Hasql.Postgres.PTI where import Hasql.Postgres.Prelude hiding (bool)-import Database.PostgreSQL.LibPQ (Oid(..))+import qualified Database.PostgreSQL.LibPQ as PQ -- | A Postgresql type info-data PTI = PTI { oidOf :: Oid, arrayOIDOf :: Maybe Oid }+data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(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))+-- | A Word32 and a LibPQ representation of an OID+data OID = OID { oidWord32 :: !Word32, oidPQ :: !PQ.Oid }++mkOID :: Word32 -> OID+mkOID x =+ OID x ((PQ.Oid . fromIntegral) x)++mkPTI :: Word32 -> Maybe Word32 -> PTI+mkPTI oid arrayOID =+ PTI (mkOID oid) (fmap mkOID arrayOID)+++-- * Constants+-------------------------++abstime = mkPTI 702 (Just 1023)+aclitem = mkPTI 1033 (Just 1034)+bit = mkPTI 1560 (Just 1561)+bool = mkPTI 16 (Just 1000)+box = mkPTI 603 (Just 1020)+bpchar = mkPTI 1042 (Just 1014)+bytea = mkPTI 17 (Just 1001)+char = mkPTI 18 (Just 1002)+cid = mkPTI 29 (Just 1012)+cidr = mkPTI 650 (Just 651)+circle = mkPTI 718 (Just 719)+cstring = mkPTI 2275 (Just 1263)+date = mkPTI 1082 (Just 1182)+daterange = mkPTI 3912 (Just 3913)+float4 = mkPTI 700 (Just 1021)+float8 = mkPTI 701 (Just 1022)+gtsvector = mkPTI 3642 (Just 3644)+inet = mkPTI 869 (Just 1041)+int2 = mkPTI 21 (Just 1005)+int2vector = mkPTI 22 (Just 1006)+int4 = mkPTI 23 (Just 1007)+int4range = mkPTI 3904 (Just 3905)+int8 = mkPTI 20 (Just 1016)+int8range = mkPTI 3926 (Just 3927)+interval = mkPTI 1186 (Just 1187)+json = mkPTI 114 (Just 199)+line = mkPTI 628 (Just 629)+lseg = mkPTI 601 (Just 1018)+macaddr = mkPTI 829 (Just 1040)+money = mkPTI 790 (Just 791)+name = mkPTI 19 (Just 1003)+numeric = mkPTI 1700 (Just 1231)+numrange = mkPTI 3906 (Just 3907)+oid = mkPTI 26 (Just 1028)+oidvector = mkPTI 30 (Just 1013)+path = mkPTI 602 (Just 1019)+point = mkPTI 600 (Just 1017)+polygon = mkPTI 604 (Just 1027)+record = mkPTI 2249 (Just 2287)+refcursor = mkPTI 1790 (Just 2201)+regclass = mkPTI 2205 (Just 2210)+regconfig = mkPTI 3734 (Just 3735)+regdictionary = mkPTI 3769 (Just 3770)+regoper = mkPTI 2203 (Just 2208)+regoperator = mkPTI 2204 (Just 2209)+regproc = mkPTI 24 (Just 1008)+regprocedure = mkPTI 2202 (Just 2207)+regtype = mkPTI 2206 (Just 2211)+reltime = mkPTI 703 (Just 1024)+text = mkPTI 25 (Just 1009)+tid = mkPTI 27 (Just 1010)+time = mkPTI 1083 (Just 1183)+timestamp = mkPTI 1114 (Just 1115)+timestamptz = mkPTI 1184 (Just 1185)+timetz = mkPTI 1266 (Just 1270)+tinterval = mkPTI 704 (Just 1025)+tsquery = mkPTI 3615 (Just 3645)+tsrange = mkPTI 3908 (Just 3909)+tstzrange = mkPTI 3910 (Just 3911)+tsvector = mkPTI 3614 (Just 3643)+txid_snapshot = mkPTI 2970 (Just 2949)+unknown = mkPTI 705 Nothing+uuid = mkPTI 2950 (Just 2951)+varbit = mkPTI 1562 (Just 1563)+varchar = mkPTI 1043 (Just 1015)+void = mkPTI 2278 Nothing+xid = mkPTI 28 (Just 1011)+xml = mkPTI 142 (Just 143)
− library/Hasql/Postgres/Parser.hs
@@ -1,364 +0,0 @@-module Hasql.Postgres.Parser where--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---type P = Parser--run :: ByteString -> P 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---- ** Parser----------------------------{-# INLINE labeling #-}-labeling :: String -> Parser a -> Parser a-labeling n p = - p <?> n--scientific :: P Scientific-scientific =- A.scientific--float :: P Float-float =- realToFrac <$> double--double :: P Double-double = - labeling "double" $ A.double--bool :: P Bool-bool =- labeling "bool" $- ((string "true" <|> string "t" <|> string "True" <|> string "1") *> pure True) <|>- ((string "false" <|> string "f" <|> string "False" <|> string "0") *> pure False)--utf8Char :: P Char-utf8Char =- labeling "utf8Char" $- asum $ map byLength [1..4]- where- byLength l =- do- b <- take l- t <- either (const empty) return $ Data.Text.Encoding.decodeUtf8' b- (c, _) <- maybe empty return $ Data.Text.uncons t- return c--utf8LazyText :: P Data.Text.Lazy.Text-utf8LazyText =- labeling "utf8LazyText" $ do- b <- takeLazyByteString- either (const empty) return $ Data.Text.Lazy.Encoding.decodeUtf8' b--utf8Text :: P Text-utf8Text =- Data.Text.Lazy.toStrict <$> utf8LazyText--charUnit :: Char -> P ()-charUnit c = - skip ((==) (fromIntegral (ord c)))---- | A signed integral value from a sequence of characters.-{-# INLINE integral #-}-integral :: (Integral a, Num a) => P a-integral =- signed decimal- --- | An unsigned integral value from a sequence of characters.-{-# INLINE unsignedIntegral #-}-unsignedIntegral :: (Integral a, Num a) => P a-unsignedIntegral =- decimal---- | An integral value from a single character.-{-# INLINE integralDigit #-}-integralDigit :: Integral a => P a-integralDigit = - satisfyWith (subtract 48 . fromIntegral) (\n -> n < 10 && n >= 0)--day :: P Day-day =- do- y <- unsignedIntegral- charUnit '-'- m <- unsignedIntegral- charUnit '-'- d <- unsignedIntegral- maybe empty return (fromGregorianValid y m d)--timeOfDay :: P TimeOfDay-timeOfDay =- do- h <- unsignedIntegral- charUnit ':'- m <- unsignedIntegral- charUnit ':'- s <- unsignedIntegral- p <- (charUnit '.' *> decimals) <|> pure 0- maybe empty return - (makeTimeOfDayValid h m (fromIntegral s + p))- where- decimals = do- (b, i) <- match unsignedIntegral- return $ fromIntegral i / (10 ^ Data.ByteString.length b)--localTime :: P LocalTime-localTime = - LocalTime <$> day <*> (charUnit ' ' *> timeOfDay)--timeZoneTuple :: P (Bool, Int, Int, Int)-timeZoneTuple =- do- p <- (charUnit '+' *> pure True) <|> (charUnit '-' *> pure False)- h <- unsignedIntegral- m <- (charUnit ':' *> unsignedIntegral) <|> pure 0- s <- (charUnit ':' *> unsignedIntegral) <|> pure 0- return $! (p, h, m, s)--timeZone :: P TimeZone-timeZone =- do- (p, h, m, s) <- timeZoneTuple- return $!- minutesToTimeZone ((if p then id else negate) (60 * h + m))---- |--- Takes seconds in timezone into account.-zonedTime :: P ZonedTime-zonedTime = - do- LocalTime d t <- localTime- (zp, zh, zm, zs) <- timeZoneTuple- return $ ZonedTime (LocalTime d (timeOfDayDiffSecs zs t)) (composeTimezone zp zh zm)- where- timeOfDayDiffSecs s =- if s /= 0- then \t -> timeToTimeOfDay $ timeOfDayToTime t - fromIntegral s- else id- composeTimezone p h m =- minutesToTimeZone ((if p then id else negate) (60 * h + m))--utcTime :: P UTCTime-utcTime =- UTCTime <$> day <*> (charUnit ' ' *> diffTime)--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/Prelude.hs view
@@ -12,16 +12,12 @@ -- base-prelude --------------------------import BasePrelude as Exports+import BasePrelude as Exports hiding (assert) -- mtl-prelude ------------------------- import MTLPrelude as Exports hiding (shift) --- mmorph---------------------------import Control.Monad.Morph as Exports- -- list-t ------------------------- import ListT as Exports (ListT)@@ -42,13 +38,13 @@ ------------------------- import Data.Scientific as Exports (Scientific) --- time+-- uuid --------------------------import Data.Time as Exports+import Data.UUID as Exports (UUID) --- old-locale+-- time --------------------------import System.Locale as Exports+import Data.Time as Exports -- vector -------------------------@@ -57,6 +53,10 @@ -- placeholders ------------------------- import Development.Placeholders as Exports++-- loch-th+-------------------------+import Debug.Trace.LocationTH as Exports -- custom -------------------------
− library/Hasql/Postgres/Renderer.hs
@@ -1,312 +0,0 @@--- |--- Useful info:--- https://github.com/hdbc/hdbc/blob/7ed3dfad534773cbfe2811ea241d245009e2961b/Database/HDBC/SqlValue.hs#L252-module Hasql.Postgres.Renderer where--import Hasql.Postgres.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.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 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 -> BB.Builder--run :: a -> R a -> ByteString-run a f =- (BL.toStrict . BB.toLazyByteString . f) a----- ** Renderer----------------------------ascii :: Show a => R a-ascii =- BB.string7 . show----- *** strings----------------------------char7 :: R Char = - BB.char7--char :: R Char = - BB.charUtf8--string7 :: R String = - BB.string7--string :: R String = - BB.string8--byteString :: R ByteString = - BB.byteString--lazyByteString :: R LazyByteString = - BB.lazyByteString--text :: R Text =- T.encodeUtf8Builder--lazyText :: R LazyText =- TL.encodeUtf8Builder----- *** enumerations----------------------------bool :: R Bool =- \b -> if b then word8 1 else word8 0--word8 :: R Word8 =- BB.word8Dec--word16 :: R Word16 =- BB.word16Dec--word32 :: R Word32 =- BB.word32Dec--word64 :: R Word64 =- BB.word64Dec--word :: R Word =- BB.wordDec--int8 :: R Int8 =- BB.int8Dec--int16 :: R Int16 =- BB.int16Dec--int32 :: R Int32 =- BB.int32Dec--int64 :: R Int64 =- BB.int64Dec--int :: R Int =- BB.intDec--integer :: R Integer =- BB.integerDec--paddedInt :: Int -> R Int-paddedInt padding n =- if padding <= width- then int n- else mconcat (replicate (padding - width) (BB.char7 '0')) <> int n- where- width = fromIntegral (succ (floor (logBase 10 (fromIntegral n))) :: Integer)- ---- *** fractionals----------------------------float :: R Float =- BB.floatDec- -double :: R Double =- BB.doubleDec--pico :: R Pico =- BB.string7 . showFixed True--scientific :: R Scientific =- Data.ByteString.Builder.Scientific.scientificBuilder----- *** time----------------------------day :: R Day = - BB.string7 . formatTime defaultTimeLocale (iso8601DateFormat Nothing)--timeOfDay :: R TimeOfDay = - BB.string7 . formatTime defaultTimeLocale "%T%Q"--localTime :: R LocalTime = - BB.string7 . formatTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q"))--timeZone :: R TimeZone =- \(TimeZone t _ _) ->- if t < 0- then BB.char7 '-' <> uncurry hm (divMod (negate t) 60)- else BB.char7 '+' <> uncurry hm (divMod t 60)- where- hm h m = - paddedInt 2 h <> BB.char7 ':' <> paddedInt 2 m --zonedTime :: R ZonedTime = - \(ZonedTime lt tz) ->- localTime lt <> timeZone tz--utcTime :: R UTCTime = - 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,9 @@ import Hasql.Postgres.Prelude import qualified Database.PostgreSQL.LibPQ as L-import qualified Hasql.Postgres.Renderer as Renderer+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL type Statement =@@ -48,30 +50,29 @@ (template, [], False) where template =- Renderer.run cursor $ \c -> Renderer.string7 "CLOSE " <> Renderer.byteString c+ "CLOSE " <> cursor fetchFromCursor :: Cursor -> Statement fetchFromCursor cursor = (template, [], False) where template =- Renderer.run cursor $ \c -> - Renderer.string7 "FETCH FORWARD 256 FROM " <> Renderer.byteString c+ "FETCH FORWARD 256 FROM " <> cursor beginTransaction :: TransactionMode -> Statement-beginTransaction mode =+beginTransaction (i, w) = (template, [], True) where template =- Renderer.run mode $ \(i, w) ->- mconcat $ intersperse (Renderer.char7 ' ') $+ BL.toStrict $ BB.toLazyByteString $+ mconcat $ intersperse (BB.char7 ' ') $ [- Renderer.string7 "BEGIN"+ BB.string7 "BEGIN" , case i of- ReadCommitted -> Renderer.string7 "ISOLATION LEVEL READ COMMITTED"- RepeatableRead -> Renderer.string7 "ISOLATION LEVEL REPEATABLE READ"- Serializable -> Renderer.string7 "ISOLATION LEVEL SERIALIZABLE"+ ReadCommitted -> BB.string7 "ISOLATION LEVEL READ COMMITTED"+ RepeatableRead -> BB.string7 "ISOLATION LEVEL REPEATABLE READ"+ Serializable -> BB.string7 "ISOLATION LEVEL SERIALIZABLE" , case w of True -> "READ WRITE"
library/Hasql/Postgres/StatementPreparer.hs view
@@ -5,9 +5,11 @@ import Hasql.Postgres.Prelude import qualified Data.HashTable.IO as Hashtables import qualified Database.PostgreSQL.LibPQ as PQ-import qualified Hasql.Postgres.Renderer as Renderer import qualified Hasql.Postgres.ResultParser as Result import qualified Hasql.Postgres.ResultHandler as ResultHandler+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL @@ -48,7 +50,7 @@ Nothing -> do w <- readIORef counter- n <- return (Renderer.run w Renderer.word16)+ n <- return (BL.toStrict $ BB.toLazyByteString $ BB.word16Dec w) ResultHandler.unit =<< Result.parse c =<< PQ.prepare c n s (partial (not . null) tl) Hashtables.insert table k n writeIORef counter (succ w)
tests/Main.hs view
@@ -131,28 +131,22 @@ validMappingSession v1 validMappingSession v2 where- v1 = Vector.fromList [v2, v2]- v2 = Vector.fromList [Just 'a', Nothing, Just 'b']+ v1 = [v2, v2]+ v2 = [Just 'a', Nothing, Just 'b'] -test_mappingOfVector2 =+test_mappingOfList2 = session1 $ do validMappingSession v1 validMappingSession v2 where- v1 = Vector.fromList [v2, v2]- v2 = Vector.fromList [Just (1 :: Int), Just 2, Nothing]+ v1 = [v2, v2]+ v2 = [Just (1 :: Int), Just 2, Nothing] -test_mappingOfVector3 =+test_mappingOfList3 = session1 $ do- validMappingSession v1- where- v1 =- Vector.fromList- [- " 'a' \"b\" \\c\\ " :: Text- ]+ validMappingSession [" 'a' \"b\" \\c\\ " :: Text] -test_mappingOfVector4 =+test_mappingOfList4 = assertEqual (Just (Identity v1)) =<< do session1 $ tx Nothing $ do unit $ [q|DROP TABLE IF EXISTS a|]@@ -161,31 +155,20 @@ single $ [q|SELECT v FROM a|] where v1 =- Vector.fromList- [- Vector.fromList [Just 'a', Just 'b'],- Vector.fromList [Nothing, Just 'c']- ]+ [+ [Just 'a', Just 'b'],+ [Nothing, Just 'c']+ ] -test_mappingOfVector5 =+test_mappingOfList5 = session1 $ do- validMappingSession v1- where- v1 =- Vector.fromList- [- " 'a' \"b\" \\c\\ ф" :: ByteString- ]+ validMappingSession [" 'a' \"b\" \\c\\ ф" :: ByteString] -prop_mappingOfVectorOverByteString (list :: [ByteString]) =- mappingProp v- where- v = Vector.fromList list+prop_mappingOfListOverByteString (x :: [ByteString]) =+ mappingProp x -prop_mappingOfVectorOverLazyByteString (list :: [LazyByteString]) =- mappingProp v- where- v = Vector.fromList list+prop_mappingOfListOverLazyByteString (x :: [LazyByteString]) =+ mappingProp x test_mappingOfBool = session1 $ do@@ -267,17 +250,6 @@ forAll microsLocalTimeGen $ \v -> mappingProp v -prop_mappingOfZonedTime =- forAll gen $ \v -> - eq v $ fromJust $ do unsafePerformIO $ session1 $ selectSelf v- where- eq a b = zonedTimeToUTC a === zonedTimeToUTC b- gen =- do- t <- microsLocalTimeGen- z <- minutesToTimeZone <$> choose (negate (11 * 60 + 59), 11 * 60 + 59)- return $ ZonedTime t z- prop_mappingOfUTCTime = forAll gen $ \v -> mappingProp v@@ -341,4 +313,6 @@ mappingProp :: (Show a, Eq a, Backend.Mapping Postgres a) => a -> Property mappingProp v =- Just v === do unsafePerformIO $ session1 $ selectSelf v+ Right v === do + unsafePerformIO $ (try :: IO a -> IO (Either H.Error a)) $ fmap fromJust $ + session1 $ selectSelf v