hasql-postgres 0.2.0 → 0.3.0
raw patch · 5 files changed
+249/−103 lines, 5 filesdep ~postgresql-binaryPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: postgresql-binary
API changes (from Hackage documentation)
Files
- competition/Main.hs +7/−5
- hasql-postgres.cabal +5/−5
- library/Hasql/Postgres.hs +36/−27
- library/Hasql/Postgres/Connector.hs +3/−4
- library/Hasql/Postgres/Mapping.hs +198/−62
competition/Main.hs view
@@ -103,8 +103,10 @@ standoff "Templates and rendering" $ do rows :: [(Text, Day)] <- - liftIO $ replicateM 100 $ - (,) <$> Q.generate Q.arbitrary <*> Q.generate Q.arbitrary+ liftIO $ Q.generate $ replicateM 100 $ + (,) <$> Q.arbitrary <*> Q.arbitrary+ + let !day = read "2014-10-26" :: Day subject "hasql" $ do pause@@ -122,7 +124,7 @@ [H.q|SELECT * FROM a WHERE id > ? AND id < ? AND birthday != ?|] (1000 :: Int) (0 :: Int) - (read "2014-10-26" :: Day)+ (day) :: H.Tx H.Postgres s [(Int, Text, Day)] lift $ pause @@ -138,7 +140,7 @@ continue liftIO $ replicateM_ 1000 $ do P.query c "SELECT * FROM a WHERE id > ? AND id < ? AND birthday != ?" - (1000 :: Int, 0 :: Int, read "2014-10-26" :: Day) + (1000 :: Int, 0 :: Int, day) :: IO [(Int, Text, Day)] pause liftIO $ P.close c@@ -165,7 +167,7 @@ continue liftIO $ replicateM_ 1000 $ do C.quickQuery c "SELECT * FROM a WHERE id > ? AND id < ? AND birthday != ?" - [C.toSql (1000 :: Int), C.toSql (0 :: Int), C.toSql (read "2014-10-26" :: Day)]+ [C.toSql (1000 :: Int), C.toSql (0 :: Int), C.toSql (day)] pause liftIO $ C.disconnect c
hasql-postgres.cabal view
@@ -1,7 +1,7 @@ name: hasql-postgres version:- 0.2.0+ 0.3.0 synopsis: A "PostgreSQL" backend for the "hasql" library description:@@ -9,8 +9,8 @@ <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\".+ it performs up to 2x faster than \"postgresql-simple\" and+ up to 7x faster than \"HDBC\". You can read up <http://nikita-volkov.github.io/hasql-benchmarks/ a post with analysis of those benchmarks>. category:@@ -72,7 +72,7 @@ attoparsec == 0.12.*, -- database: hasql-backend == 0.1.*,- postgresql-binary == 0.1.*,+ postgresql-binary == 0.2.*, postgresql-libpq == 0.9.*, -- data: uuid == 1.3.*,@@ -122,7 +122,7 @@ attoparsec == 0.12.*, -- database: hasql >= 0.1.4 && < 0.2,- postgresql-binary == 0.1.*,+ postgresql-binary == 0.2.*, postgresql-libpq == 0.9.*, -- data: uuid == 1.3.*,
library/Hasql/Postgres.hs view
@@ -46,45 +46,52 @@ } instance Backend.Backend Postgres where- newtype StatementArgument Postgres = - StatementArgument {unpackStatementArgument :: (PQ.Oid, Maybe (ByteString, PQ.Format))}- newtype Result Postgres = - Result {unpackResult :: (Maybe ByteString)}+ data StatementArgument Postgres = + StatementArgument PQ.Oid (Mapping.Environment -> Maybe ByteString)+ data Result Postgres = + Result Mapping.Environment (Maybe ByteString) data Connection Postgres = Connection { connection :: !PQ.Connection, preparer :: !StatementPreparer.StatementPreparer,- transactionState :: !(IORef (Maybe Word))+ transactionState :: !(IORef (Maybe Word)),+ environment :: Mapping.Environment } connect p = do r <- runExceptT $ Connector.open settings- case r of- Left e -> - throwIO $ Backend.CantConnect $ fromString $ show e- Right c ->- Connection <$> pure c <*> StatementPreparer.new c <*> newIORef Nothing+ c <- either (\e -> throwIO $ Backend.CantConnect $ fromString $ show e) return r+ Connection <$> pure c <*> StatementPreparer.new c <*> newIORef Nothing <*> getIntegerDatetimes c where settings = Connector.Settings (host p) (port p) (user p) (password p) (database p)+ getIntegerDatetimes c =+ fmap parseResult $ PQ.parameterStatus c "integer_datetimes"+ where+ parseResult = + \case+ Just "on" -> True+ _ -> False disconnect c = PQ.finish (connection c) execute s c = - ResultHandler.unit =<< execute (liftStatement s) c+ ResultHandler.unit =<< execute (liftStatement c s) c executeAndGetMatrix s c =- {-# SCC "executeAndGetMatrix" #-} - unsafeCoerce . ResultHandler.rowsVector =<< execute (liftStatement s) c+ execute (liftStatement c s) c >>=+ (fmap . fmap . fmap) (Result (environment c)) . ResultHandler.rowsVector executeAndStream s c = do name <- declareCursor- return $ unsafeCoerce $+ return $ let loop = do chunk <- lift $ fetchFromCursor name null <- lift $ ListT.null chunk guard $ not null- chunk <> loop+ (fmap . fmap) packResult chunk <> loop in loop where+ packResult = + Result (environment c) nextName = do counterM <- readIORef (transactionState c)@@ -94,7 +101,7 @@ declareCursor = do name <- nextName- ResultHandler.unit =<< execute (Statement.declareCursor name (liftStatement s)) c+ ResultHandler.unit =<< execute (Statement.declareCursor name (liftStatement c s)) c return name fetchFromCursor name = ResultHandler.rowsStream =<< execute (Statement.fetchFromCursor name) c@@ -102,7 +109,7 @@ ResultHandler.unit =<< execute (Statement.closeCursor name) c executeAndCountEffects s c = do- b <- ResultHandler.rowsAffected =<< execute (liftStatement s) c+ b <- ResultHandler.rowsAffected =<< execute (liftStatement c s) c case Atto.parseOnly (Atto.decimal <* Atto.endOfInput) b of Left m -> throwIO $ Backend.UnexpectedResult (fromString m)@@ -124,9 +131,12 @@ ResultHandler.unit =<< execute (bool Statement.abortTransaction Statement.commitTransaction commit) c writeIORef (transactionState c) Nothing -liftStatement :: Backend.Statement Postgres -> Statement.Statement-liftStatement (template, values) =- (template, map unpackStatementArgument values, True)+liftStatement :: Backend.Connection Postgres -> Backend.Statement Postgres -> Statement.Statement+liftStatement c (template, arguments) =+ (,,) template (map liftArgument arguments) True+ where+ liftArgument (StatementArgument o f) = + (,) o ((,) <$> f (environment c) <*> pure PQ.Binary) execute :: Statement.Statement -> Backend.Connection Postgres -> IO ResultParser.Result execute s c =@@ -164,15 +174,14 @@ {-# 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+ StatementArgument+ (PTI.oidPQ $ Mapping.oid x)+ (flip Mapping.encode x) {-# INLINE parseResultUsingMapping #-} parseResultUsingMapping :: Mapping.Mapping a => Backend.Result Postgres -> Either Text a-parseResultUsingMapping (Result x) = - Mapping.decode x+parseResultUsingMapping (Result e x) = + Mapping.decode e x -- | -- Maps to the same type as the underlying value, @@ -204,7 +213,7 @@ -- -- /LIMITATION 2/ -- --- 'Maybe' cannot be used to wrap an intermediate level in a multidimensional array.+-- 'Maybe' cannot be used to wrap an intermediate level in a multidimensional list. -- -- E.g., the following is a corrupt type: --
library/Hasql/Postgres/Connector.hs view
@@ -49,11 +49,10 @@ v <- lift $ L.serverVersion c when (v < 80200) $ throwError $ UnsupportedVersion v lift $ L.exec c $ mconcat $ map (<> ";") $ - [ "SET standard_conforming_strings TO on",- "SET datestyle TO ISO",+ [ "SET client_encoding = 'UTF8'",- "SET client_min_messages TO WARNING",- "SET bytea_output = 'hex'" ]+ "SET client_min_messages TO WARNING"+ ] return c
library/Hasql/Postgres/Mapping.hs view
@@ -13,6 +13,13 @@ import qualified PostgreSQLBinary.Decoder as Decoder +-- |+-- Server settings.+-- +-- * @integer_datetimes@+type Environment =+ Bool+ type Value = Maybe ByteString @@ -20,113 +27,242 @@ -- A final value level mapping. class Mapping a where oid :: a -> PTI.OID- encode :: a -> Value- decode :: Value -> Either Text a+ encode :: Environment -> a -> Value+ decode :: Environment -> 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+ arrayEncode :: Environment -> a -> Array.Data+ arrayDecode :: Environment -> 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)+ encode e = + join . traverse (encode e)+ decode e = + maybe (return Nothing) (fmap Just . (decode e) . Just) instance (ArrayMapping a, Mapping a) => ArrayMapping (Maybe a) where arrayOID = const $ arrayOID (undefined :: a)- arrayEncode =+ arrayEncode e = \case Nothing -> Array.fromSingleton Nothing True (PTI.oidWord32 (oid (undefined :: a))) Just x ->- setNullable True $ arrayEncode x+ setNullable True $ arrayEncode e x where setNullable x (dl, vl, _, oid) = (dl, vl, True, oid)- arrayDecode =+ arrayDecode e = \case- (_, [x], _, _) -> decode x+ (_, [x], _, _) -> decode e 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 = + encode e = + Just . Encoder.array . arrayEncode e+ decode e x = do b <- maybe (Left "NULL input") return x a <- Decoder.array b- arrayDecode a+ arrayDecode e a instance (Mapping a, ArrayMapping a) => ArrayMapping [a] where arrayOID = const $ arrayOID (undefined :: a)- arrayEncode =+ arrayEncode e = \case [] -> ([(0, 1)], [], False, PTI.oidWord32 $ oid (undefined :: a))- x -> Array.fromListUnsafe . map arrayEncode $ x- arrayDecode x =- traverse arrayDecode $ Array.elements x+ x -> Array.fromListUnsafe . map (arrayEncode e) $ x+ arrayDecode e x =+ traverse (arrayDecode e) $ Array.elements x instance (Mapping a, ArrayMapping a) => Mapping (Vector a) where oid = arrayOID- encode = - Just . Encoder.array . arrayEncode- decode x = + encode e = + Just . Encoder.array . arrayEncode e+ decode e x = do b <- maybe (Left "NULL input") return x a <- Decoder.array b- arrayDecode a+ arrayDecode e a instance (Mapping a, ArrayMapping a) => ArrayMapping (Vector a) where arrayOID = const $ arrayOID (undefined :: a)- arrayEncode =- arrayEncode . V.toList- arrayDecode =- fmap V.fromList . arrayDecode+ arrayEncode e =+ arrayEncode e . V.toList+ arrayDecode e =+ fmap V.fromList . arrayDecode e 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|])+ (,,,)+ [t|Int|]+ [|PTI.int8|]+ [|const $ Encoder.int8 . Left . fromIntegral|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Int8|]+ [|PTI.int2|]+ [|const $ Encoder.int2 . Left . fromIntegral|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Int16|]+ [|PTI.int2|]+ [|const $ Encoder.int2 . Left|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Int32|]+ [|PTI.int4|]+ [|const $ Encoder.int4 . Left|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Int64|]+ [|PTI.int8|]+ [|const $ Encoder.int8 . Left|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Word|]+ [|PTI.int8|]+ [|const $ Encoder.int8 . Right . fromIntegral|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Word8|]+ [|PTI.int2|]+ [|const $ Encoder.int2 . Right . fromIntegral|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Word16|]+ [|PTI.int2|]+ [|const $ Encoder.int2 . Right|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Word32|]+ [|PTI.int4|]+ [|const $ Encoder.int4 . Right|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Word64|]+ [|PTI.int8|]+ [|const $ Encoder.int8 . Right|]+ [|const $ Decoder.int|]+ ,+ (,,,)+ [t|Float|]+ [|PTI.float4|]+ [|const $ Encoder.float4|]+ [|const $ Decoder.float4|]+ ,+ (,,,)+ [t|Double|]+ [|PTI.float8|]+ [|const $ Encoder.float8|]+ [|const $ Decoder.float8|]+ ,+ (,,,)+ [t|Scientific|]+ [|PTI.numeric|]+ [|const $ Encoder.numeric|]+ [|const $ Decoder.numeric|]+ ,+ (,,,)+ [t|Day|]+ [|PTI.date|]+ [|const $ Encoder.date|]+ [|const $ Decoder.date|]+ ,+ (,,,)+ [t|TimeOfDay|]+ [|PTI.time|]+ [|Encoder.time|]+ [|Decoder.time|]+ ,+ (,,,)+ [t|(TimeOfDay, TimeZone)|]+ [|PTI.timetz|]+ [|Encoder.timetz|]+ [|Decoder.timetz|]+ ,+ (,,,)+ [t|UTCTime|]+ [|PTI.timestamp|]+ [|const $ Encoder.timestamp|]+ [|const $ Decoder.timestamp|]+ ,+ (,,,)+ [t|LocalTime|]+ [|PTI.timestamptz|]+ [|const $ Encoder.timestamptz|]+ [|const $ Decoder.timestamptz|]+ ,+ (,,,)+ [t|DiffTime|]+ [|PTI.interval|]+ [|const $ Encoder.interval|]+ [|const $ Decoder.interval|]+ ,+ (,,,)+ [t|Char|]+ [|PTI.text|]+ [|const $ Encoder.char|]+ [|const $ Decoder.char|]+ ,+ (,,,)+ [t|Text|]+ [|PTI.text|]+ [|const $ Encoder.text . Left|]+ [|const $ Decoder.text|]+ ,+ (,,,)+ [t|LazyText|]+ [|PTI.text|]+ [|const $ Encoder.text . Right|]+ [|const $ fmap TL.fromStrict . Decoder.text|]+ ,+ (,,,)+ [t|ByteString|]+ [|PTI.bytea|]+ [|const $ Encoder.bytea . Left|]+ [|const $ Decoder.bytea|]+ ,+ (,,,)+ [t|LazyByteString|]+ [|PTI.bytea|]+ [|const $ Encoder.bytea . Right|]+ [|const $ fmap BL.fromStrict . Decoder.bytea|]+ ,+ (,,,)+ [t|Bool|]+ [|PTI.bool|]+ [|const $ Encoder.bool|]+ [|const $ Decoder.bool|]+ ,+ (,,,)+ [t|UUID|]+ [|PTI.uuid|]+ [|const $ Encoder.uuid|]+ [|const $ Decoder.uuid|] ] in fmap concat $ forM settings $ \(t, pti, encoder, decoder) ->@@ -137,27 +273,27 @@ oid = const $ PTI.ptiOID $pti {-# INLINE encode #-}- encode =- Just . $encoder+ encode e =+ Just . $encoder e {-# INLINE decode #-}- decode x =+ decode e x = do b <- maybe (Left "NULL input") return x- $decoder b+ $decoder e 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))+ arrayEncode e x =+ Array.fromSingleton (Just ($encoder e x)) (False) (PTI.oidWord32 (PTI.ptiOID $pti)) {-# INLINE arrayDecode #-}- arrayDecode =+ arrayDecode e = \case- (_, [x], _, _) -> decode x+ (_, [x], _, _) -> decode e x x -> Left $ "Array data doesn't match the '" <> $(t >>= TH.stringE . show) <> "' type: " <> (fromString . show) x