hasql-postgres (empty) → 0.1.0
raw patch · 20 files changed
+2316/−0 lines, 20 filesdep +Decimaldep +HTFdep +HUnitsetup-changed
Dependencies added: Decimal, HTF, HUnit, QuickCheck, SafeSemaphore, attoparsec, base, base-prelude, bytestring, criterion-plus, hashable, hashtables, hasql, hasql-backend, hasql-postgres, list-t, loch-th, mmorph, mtl-prelude, old-locale, placeholders, postgresql-libpq, postgresql-simple, quickcheck-instances, scientific, slave-thread, text, time, utf8-string, vector
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- competition/Main.hs +163/−0
- hasql-postgres.cabal +255/−0
- library-tests/Main.hs +11/−0
- library/Hasql/Postgres.hs +237/−0
- library/Hasql/Postgres/Connector.hs +67/−0
- library/Hasql/Postgres/ErrorCode.hs +409/−0
- library/Hasql/Postgres/OID.hs +54/−0
- library/Hasql/Postgres/Parser.hs +144/−0
- library/Hasql/Postgres/Prelude.hs +76/−0
- library/Hasql/Postgres/Renderer.hs +162/−0
- library/Hasql/Postgres/ResultHandler.hs +75/−0
- library/Hasql/Postgres/ResultParser.hs +185/−0
- library/Hasql/Postgres/Statement.hs +90/−0
- library/Hasql/Postgres/StatementPreparer.hs +55/−0
- library/Hasql/Postgres/TemplateConverter.hs +22/−0
- library/Hasql/Postgres/TemplateConverter/Parser.hs +39/−0
- profiling/Main.hs +36/−0
- tests/Main.hs +212/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2014, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ competition/Main.hs view
@@ -0,0 +1,163 @@+import BasePrelude+import MTLPrelude+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Time+import CriterionPlus+import qualified Hasql as H+import qualified Hasql.Postgres as H+import qualified ListT+import qualified Database.PostgreSQL.Simple as P+import qualified Database.PostgreSQL.Simple.SqlQQ as P+import qualified Database.PostgreSQL.Simple.FromField as P+import qualified Database.PostgreSQL.Simple.ToField as P+import qualified Database.PostgreSQL.Simple.FromRow as P+import qualified Database.PostgreSQL.Simple.ToRow as P+import qualified Database.PostgreSQL.Simple.Transaction as P+import qualified Test.QuickCheck.Gen as Q+import qualified Test.QuickCheck.Arbitrary as Q+import qualified Test.QuickCheck.Instances+++main =+ benchmark $ do++ standoff "Results parsing" $ do++ rows :: [(Text, Day)] <- + liftIO $ replicateM 100 $ + (,) <$> Q.generate Q.arbitrary <*> Q.generate Q.arbitrary++ subject "hasql" $ do+ pause+ H.session (H.Postgres host port user password db) (fromJust $ H.sessionSettings 1 30) $ do+ H.tx Nothing $ do+ H.unit [H.q|DROP TABLE IF EXISTS a|]+ H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE,+ PRIMARY KEY (id))|]+ forM_ rows $ \(name, birthday) -> do+ H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday+ lift $ continue+ replicateM_ 100 $ do+ H.tx Nothing $ do+ H.list $ [H.q|SELECT * FROM a|] :: H.Tx H.Postgres s [(Int, Text, Day)]+ lift $ pause++ subject "postgresql-simple" $ do+ pause+ c <- liftIO $ P.connect $ P.ConnectInfo host port user password db+ liftIO $ P.execute_ c "SET client_min_messages TO WARNING"+ liftIO $ P.execute_ c "DROP TABLE IF EXISTS a"+ liftIO $ P.execute_ c [P.sql|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE, + PRIMARY KEY (id))|]+ forM_ rows $ \(name, birthday) -> do+ liftIO $ P.execute c "INSERT INTO a (name, birthday) VALUES (?, ?)" (name, birthday)+ continue+ liftIO $ replicateM_ 100 $ do+ P.query_ c "SELECT * FROM a" :: IO [(Int, Text, Day)]+ pause+ liftIO $ P.close c++ standoff "Templates and rendering" $ do++ rows :: [(Text, Day)] <- + liftIO $ replicateM 100 $ + (,) <$> Q.generate Q.arbitrary <*> Q.generate Q.arbitrary++ subject "hasql" $ do+ pause+ H.session (H.Postgres host port user password db) (fromJust $ H.sessionSettings 1 30) $ do+ H.tx Nothing $ do+ H.unit [H.q|DROP TABLE IF EXISTS a|]+ H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE,+ PRIMARY KEY (id))|]+ lift $ continue+ replicateM_ 1000 $ do+ H.tx Nothing $ do+ H.list $ + [H.q|SELECT * FROM a WHERE id > ? AND id < ? AND birthday != ?|] + (1000 :: Int)+ (0 :: Int) + (read "2014-10-26" :: Day)+ :: H.Tx H.Postgres s [(Int, Text, Day)]+ lift $ pause++ subject "postgresql-simple" $ do+ pause+ c <- liftIO $ P.connect $ P.ConnectInfo host port user password db+ liftIO $ P.execute_ c "SET client_min_messages TO WARNING"+ liftIO $ P.execute_ c "DROP TABLE IF EXISTS a"+ liftIO $ P.execute_ c [P.sql|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE, + PRIMARY KEY (id))|]+ 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) + :: IO [(Int, Text, Day)]+ pause+ liftIO $ P.close c++ standoff "Writing transaction" $ do+ + let users = 20 :: Int+ transfers = do+ a <- [1..users]+ b <- [1..users]+ if a /= b then return (a, b) else mzero+ amount = 3 :: Int64++ subject "hasql" $ do+ pause+ H.session (H.Postgres host port user password db) (fromJust $ H.sessionSettings 1 30) $ do+ H.tx Nothing $ do+ H.unit [H.q|DROP TABLE IF EXISTS a|]+ H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]+ replicateM_ users $ do+ H.unit [H.q|INSERT INTO a (balance) VALUES (0)|]+ lift $ continue+ forM_ transfers $ \(id1, id2) -> do+ H.tx (Just (H.Serializable, True)) $ do+ runMaybeT $ do+ do+ Identity balance <- MaybeT $ H.single $ [H.q|SELECT balance FROM a WHERE id=?|] id1+ lift $ H.unit $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance - amount) id1+ do+ Identity balance <- MaybeT $ H.single $ [H.q|SELECT balance FROM a WHERE id=?|] id2+ lift $ H.unit $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance + amount) id2+ lift $ pause++ subject "postgresql-simple" $ do+ pause+ c <- liftIO $ P.connect $ P.ConnectInfo host port user password db+ liftIO $ P.execute_ c "SET client_min_messages TO WARNING"+ liftIO $ P.execute_ c "DROP TABLE IF EXISTS a"+ liftIO $ P.execute_ c "CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))"+ replicateM_ users $ do+ liftIO $ P.execute_ c "INSERT INTO a (balance) VALUES (0)"+ continue+ forM_ transfers $ \(id1, id2) -> do+ liftIO $ P.withTransactionMode (P.TransactionMode P.Serializable P.ReadWrite) c $ do+ do+ [P.Only balance] <- P.query c "SELECT balance FROM a WHERE id=?" (P.Only id1)+ P.execute c "UPDATE a SET balance=? WHERE id=?" ((balance - amount), id1)+ do+ [P.Only balance] <- P.query c "SELECT balance FROM a WHERE id=?" (P.Only id2)+ P.execute c "UPDATE a SET balance=? WHERE id=?" ((balance + amount), id1)+ pause+ liftIO $ P.close c++++host = "localhost"+port = 5432+user = "postgres"+password = ""+db = "postgres"
+ hasql-postgres.cabal view
@@ -0,0 +1,255 @@+name:+ hasql-postgres+version:+ 0.1.0+synopsis:+ A "PostgreSQL" driver for the "hasql" library+description:+category:+ Database+homepage:+ https://github.com/nikita-volkov/hasql-postgres +bug-reports:+ https://github.com/nikita-volkov/hasql-postgres/issues +author:+ Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+ Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+ (c) 2014, Nikita Volkov+license:+ MIT+license-file:+ LICENSE+build-type:+ Simple+cabal-version:+ >=1.10+++source-repository head+ type:+ git+ location:+ git://github.com/nikita-volkov/hasql-postgres.git+++library+ hs-source-dirs:+ library+ ghc-options:+ -funbox-strict-fields+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ other-modules:+ Hasql.Postgres.Prelude+ Hasql.Postgres.Renderer+ Hasql.Postgres.ErrorCode+ Hasql.Postgres.OID+ Hasql.Postgres.Statement+ Hasql.Postgres.Parser+ Hasql.Postgres.StatementPreparer+ Hasql.Postgres.TemplateConverter+ Hasql.Postgres.TemplateConverter.Parser+ Hasql.Postgres.ResultHandler+ Hasql.Postgres.Connector+ Hasql.Postgres.ResultParser+ exposed-modules:+ Hasql.Postgres+ build-depends:+ -- parsers:+ attoparsec == 0.12.*,+ -- database:+ hasql-backend == 0.1.*,+ postgresql-libpq == 0.9.*,+ -- data:+ vector == 0.10.*,+ old-locale == 1.0.*,+ time == 1.4.*,+ 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.*,+ placeholders == 0.1.*,+ -- general:+ mtl-prelude == 2.0.*,+ base-prelude >= 0.1.3 && < 0.2,+ base >= 4.5 && < 4.8+++test-suite library-tests+ type: + exitcode-stdio-1.0+ hs-source-dirs: + library-tests+ library+ main-is: + Main.hs+ ghc-options:+ -threaded+ "-with-rtsopts=-N"+ -funbox-strict-fields+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ -- testing:+ HTF == 0.12.*,+ quickcheck-instances == 0.3.*,+ QuickCheck == 2.7.*,+ HUnit == 1.2.*,+ -- parsers:+ attoparsec == 0.12.*,+ -- database:+ hasql == 0.1.*,+ postgresql-libpq == 0.9.*,+ -- data:+ vector == 0.10.*,+ utf8-string >= 0.3.8 && < 0.4,+ old-locale == 1.0.*,+ time == 1.4.*,+ 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.*,+ placeholders == 0.1.*,+ -- general:+ mtl-prelude == 2.0.*,+ base-prelude >= 0.1.3 && < 0.2,+ base >= 4.5 && < 4.8+++test-suite tests+ type: + exitcode-stdio-1.0+ hs-source-dirs: + tests+ main-is: + Main.hs+ ghc-options:+ -threaded+ "-with-rtsopts=-N"+ -funbox-strict-fields+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ hasql-postgres,+ hasql-backend,+ hasql == 0.1.*,+ -- testing:+ HTF == 0.12.*,+ quickcheck-instances == 0.3.*,+ QuickCheck == 2.7.*,+ HUnit == 1.2.*,+ -- concurrency:+ SafeSemaphore == 0.10.*,+ slave-thread == 0.1.*,+ -- data:+ old-locale == 1.0.*,+ time == 1.4.*,+ scientific == 0.3.*,+ text >= 1 && < 1.3,+ bytestring >= 0.10.4.0 && < 0.11,+ hashable == 1.2.*,+ -- general:+ list-t == 0.2.*,+ mtl-prelude == 2.0.*,+ base-prelude >= 0.1.3 && < 0.2,+ base >= 4.5 && < 4.8+++benchmark competition+ type: + exitcode-stdio-1.0+ hs-source-dirs:+ competition+ main-is:+ Main.hs+ ghc-options:+ -O2+ -threaded+ "-with-rtsopts=-N"+ -funbox-strict-fields+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ postgresql-simple == 0.4.*,+ hasql-postgres,+ hasql-backend,+ hasql == 0.1.*,+ -- random:+ QuickCheck == 2.7.*,+ quickcheck-instances == 0.3.*,+ -- benchmarking:+ criterion-plus == 0.1.*,+ -- data:+ vector == 0.10.*,+ time == 1.4.*,+ text >= 1 && < 1.3,+ scientific == 0.3.*,+ -- general:+ list-t == 0.2.*,+ mtl-prelude == 2.0.*,+ base-prelude >= 0.1.3 && < 0.2,+ base >= 4.5 && < 4.8+++benchmark profiling+ type: + exitcode-stdio-1.0+ hs-source-dirs:+ profiling+ main-is:+ Main.hs+ ghc-options:+ -O2+ -threaded+ "-with-rtsopts=-N"+ -funbox-strict-fields+ -fprof-auto+ "-with-rtsopts=-N -p -s -h -i0.1"+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ postgresql-simple == 0.4.*,+ hasql-postgres,+ hasql-backend,+ hasql == 0.1.*,+ -- random:+ QuickCheck == 2.7.*,+ quickcheck-instances == 0.3.*,+ -- data:+ vector == 0.10.*,+ time == 1.4.*,+ text >= 1 && < 1.3,+ scientific == 0.3.*,+ -- general:+ list-t == 0.2.*,+ mtl-prelude == 2.0.*,+ base-prelude >= 0.1.3 && < 0.2,+ base >= 4.5 && < 4.8++
+ library-tests/Main.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import Test.Framework+import Hasql.Postgres.Prelude++import {-@ HTF_TESTS @-} Hasql.Postgres.ParserTests+import {-@ HTF_TESTS @-} Hasql.Postgres.TemplateConverterTests++main = + htfMain $ htf_thisModulesTests : htf_importedTests
+ library/Hasql/Postgres.hs view
@@ -0,0 +1,237 @@+module Hasql.Postgres (Postgres(..)) where++import Hasql.Postgres.Prelude+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Hasql.Backend as Backend+import qualified Hasql.Postgres.Connector as Connector+import qualified Hasql.Postgres.ResultParser as ResultParser+import qualified Hasql.Postgres.ResultHandler as ResultHandler+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.OID as OID+import qualified Data.Text.Encoding as Text+import qualified ListT+++-- |+-- Settings of a Postgres backend.+data Postgres =+ Postgres {+ host :: ByteString,+ port :: Word16,+ user :: Text,+ password :: Text,+ database :: Text+ }++instance Backend.Backend Postgres where+ newtype StatementArgument Postgres = + StatementArgument {unpackStatementArgument :: (PQ.Oid, Maybe (ByteString, PQ.Format))}+ newtype Result Postgres = + Result {unpackResult :: (Maybe ByteString)}+ data Connection Postgres = + Connection {+ connection :: !PQ.Connection, + preparer :: !StatementPreparer.StatementPreparer,+ transactionState :: !(IORef (Maybe Word))+ }+ 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+ where+ settings =+ Connector.Settings (host p) (port p) (user p) (password p) (database p)+ disconnect c =+ PQ.finish (connection c)+ execute s c = + ResultHandler.unit =<< execute (liftStatement s) c+ executeAndGetMatrix s c =+ unsafeCoerce . ResultHandler.rowsVector =<< execute (liftStatement s) c+ executeAndStream s c =+ do+ name <- declareCursor+ return $ unsafeCoerce $+ let loop = do+ chunk <- lift $ fetchFromCursor name+ null <- lift $ ListT.null chunk+ guard $ not null+ chunk <> loop+ in loop+ where+ nextName = + do+ 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+ declareCursor =+ do+ name <- nextName+ ResultHandler.unit =<< execute (Statement.declareCursor name (liftStatement s)) c+ return name+ fetchFromCursor name =+ ResultHandler.rowsStream =<< execute (Statement.fetchFromCursor name) c+ closeCursor name =+ ResultHandler.unit =<< execute (Statement.closeCursor name) c+ executeAndCountEffects s c =+ do+ b <- ResultHandler.rowsAffected =<< execute (liftStatement s) c+ case Parser.run b Parser.unsignedIntegral of+ Left m -> + throwIO $ Backend.UnexpectedResult m+ Right r ->+ return r+ beginTransaction (isolation, write) c = + do+ writeIORef (transactionState c) (Just 0)+ ResultHandler.unit =<< execute (Statement.beginTransaction (statementIsolation, write)) c+ where+ statementIsolation =+ case isolation of+ Backend.Serializable -> Statement.Serializable+ Backend.RepeatableReads -> Statement.RepeatableRead+ Backend.ReadCommitted -> Statement.ReadCommitted+ Backend.ReadUncommitted -> Statement.ReadCommitted+ finishTransaction commit c =+ do+ 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)++execute :: Statement.Statement -> Backend.Connection Postgres -> IO ResultParser.Result+execute s c =+ ResultParser.parse (connection c) =<< do+ let (template, params, preparable) = s+ convertedTemplate <- convertTemplate template+ case preparable of+ True -> do+ let (tl, vl) = unzip params+ key <- StatementPreparer.prepare convertedTemplate tl (preparer c)+ PQ.execPrepared (connection c) key vl PQ.Text+ False -> do+ let params' = map (\(t, v) -> (\(vb, vf) -> (t, vb, vf)) <$> v) params+ PQ.execParams (connection c) convertedTemplate params' PQ.Text++convertTemplate :: ByteString -> IO ByteString+convertTemplate t =+ case TemplateConverter.convert t of+ Left m -> + throwIO $ Backend.UnparsableTemplate $ + "Template: " <> Text.decodeLatin1 t <> ". " <>+ "Error: " <> m <> "."+ Right r ->+ return r++++-- * Mappings+-------------------------++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++instance Backend.Mapping Postgres Bool where+ renderValue = mkRenderValue OID.bool Renderer.bool+ parseResult = mkParseResult Parser.bool++instance Backend.Mapping Postgres Char where+ renderValue = mkRenderValue OID.varchar Renderer.char+ parseResult = mkParseResult Parser.utf8Char++instance Backend.Mapping Postgres Text where+ renderValue = mkRenderValue OID.text Renderer.text+ parseResult = mkParseResult Parser.utf8Text++instance Backend.Mapping Postgres Int where+ renderValue = mkRenderValue OID.int8 Renderer.int+ parseResult = mkParseResult Parser.integral++instance Backend.Mapping Postgres Int8 where+ renderValue = mkRenderValue OID.int2 Renderer.int8+ parseResult = mkParseResult Parser.integral++instance Backend.Mapping Postgres Int16 where+ renderValue = mkRenderValue OID.int2 Renderer.int16+ parseResult = mkParseResult Parser.integral++instance Backend.Mapping Postgres Int32 where+ renderValue = mkRenderValue OID.int4 Renderer.int32+ parseResult = mkParseResult Parser.integral++instance Backend.Mapping Postgres Int64 where+ renderValue = mkRenderValue OID.int8 Renderer.int64+ parseResult = mkParseResult Parser.integral++instance Backend.Mapping Postgres Word where+ renderValue = mkRenderValue OID.int8 Renderer.word+ parseResult = mkParseResult Parser.unsignedIntegral++instance Backend.Mapping Postgres Word8 where+ renderValue = mkRenderValue OID.int2 Renderer.word8+ parseResult = mkParseResult Parser.unsignedIntegral++instance Backend.Mapping Postgres Word16 where+ renderValue = mkRenderValue OID.int4 Renderer.word16+ parseResult = mkParseResult Parser.unsignedIntegral++instance Backend.Mapping Postgres Word32 where+ renderValue = mkRenderValue OID.int8 Renderer.word32+ parseResult = mkParseResult Parser.unsignedIntegral++instance Backend.Mapping Postgres Word64 where+ renderValue = mkRenderValue OID.int8 Renderer.word64+ parseResult = mkParseResult Parser.unsignedIntegral++instance Backend.Mapping Postgres Day where+ renderValue = mkRenderValue OID.date Renderer.day+ parseResult = mkParseResult Parser.day++instance Backend.Mapping Postgres TimeOfDay where+ renderValue = mkRenderValue OID.time Renderer.timeOfDay+ parseResult = mkParseResult Parser.timeOfDay++instance Backend.Mapping Postgres LocalTime where+ renderValue = mkRenderValue OID.timestamp Renderer.localTime+ parseResult = mkParseResult Parser.localTime++instance Backend.Mapping Postgres ZonedTime where+ renderValue = mkRenderValue OID.timestamptz Renderer.zonedTime + parseResult = mkParseResult Parser.zonedTime ++instance Backend.Mapping Postgres UTCTime where+ renderValue = mkRenderValue OID.timestamp Renderer.utcTime+ parseResult = mkParseResult Parser.utcTime+++-- |+-- Make a 'renderValue' function with the 'Text' format.+{-# INLINE mkRenderValue #-}+mkRenderValue :: PQ.Oid -> Renderer.R a -> (a -> Backend.StatementArgument Postgres)+mkRenderValue o r a =+ StatementArgument (o, Just (Renderer.run a r, PQ.Text))++{-# 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 -> "Input: " <> Text.decodeLatin1 r' <> ". Error: " <> t) $ + Parser.run r' p
+ library/Hasql/Postgres/Connector.hs view
@@ -0,0 +1,67 @@+-- |+-- Mid-level abstractions over gritty details of \"lib-pq\".+module Hasql.Postgres.Connector where++import Hasql.Postgres.Prelude hiding (Error)+import qualified Database.PostgreSQL.LibPQ as L+import qualified Hasql.Postgres.Renderer as Renderer+++data Settings =+ Settings {+ host :: ByteString,+ port :: Word16,+ user :: Text,+ password :: Text,+ database :: Text+ }+++-- |+-- Default settings.+settings :: Settings+settings =+ Settings "127.0.0.1" 5432 "postgres" "" ""+++data Error =+ BadStatus (Maybe ByteString) |+ UnsupportedVersion Int+ deriving (Show, Typeable)+++-- |+-- Establish and initialize a connection.+open :: Settings -> ExceptT Error IO L.Connection+open s =+ do+ c <- lift $ L.connectdb (Renderer.run s settingsRenderer)+ do+ s <- lift $ L.status c+ when (s /= L.ConnectionOk) $ + do+ m <- lift $ L.errorMessage c+ throwError $ BadStatus m+ do+ 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" ]+ return c+++settingsRenderer :: Renderer.R Settings+settingsRenderer s =+ 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)+ ]
+ library/Hasql/Postgres/ErrorCode.hs view
@@ -0,0 +1,409 @@+-- |+-- Error codes.+-- See <http://www.postgresql.org/docs/current/interactive/errcodes-appendix.html>+module Hasql.Postgres.ErrorCode where++import qualified Data.ByteString++type ErrorCode = + Data.ByteString.ByteString++-- * Class 00 — Successful Completion+-------------------------++successful_completion :: ErrorCode = "00000"++-- * Class 01 — Warning+-------------------------++warning :: ErrorCode = "01000"+dynamic_result_sets_returned :: ErrorCode = "0100C"+implicit_zero_bit_padding :: ErrorCode = "01008"+null_value_eliminated_in_set_function :: ErrorCode = "01003"+privilege_not_granted :: ErrorCode = "01007"+privilege_not_revoked :: ErrorCode = "01006"+string_data_right_truncation :: ErrorCode = "01004"+deprecated_feature :: ErrorCode = "01P01"++-- * Class 02 — No Data (this is also a warning class per the SQL standard)+-------------------------++no_data :: ErrorCode = "02000"+no_additional_dynamic_result_sets_returned :: ErrorCode = "02001"++-- * Class 03 — SQL Statement Not Yet Complete+-------------------------++sql_statement_not_yet_complete :: ErrorCode = "03000"++-- * Class 08 — Connection Exception+-------------------------++connection_exception :: ErrorCode = "08000"+connection_does_not_exist :: ErrorCode = "08003"+connection_failure :: ErrorCode = "08006"+sqlclient_unable_to_establish_sqlconnection :: ErrorCode = "08001"+sqlserver_rejected_establishment_of_sqlconnection :: ErrorCode = "08004"+transaction_resolution_unknown :: ErrorCode = "08007"+protocol_violation :: ErrorCode = "08P01"++-- * Class 09 — Triggered Action Exception+-------------------------++triggered_action_exception :: ErrorCode = "09000"++-- * Class 0A — Feature Not Supported+-------------------------++feature_not_supported :: ErrorCode = "0A000"++-- * Class 0B — Invalid Transaction Initiation+-------------------------++invalid_transaction_initiation :: ErrorCode = "0B000"++-- * Class 0F — Locator Exception+-------------------------++locator_exception :: ErrorCode = "0F000"+invalid_locator_specification :: ErrorCode = "0F001"++-- * Class 0L — Invalid Grantor+-------------------------++invalid_grantor :: ErrorCode = "0L000"+invalid_grant_operation :: ErrorCode = "0LP01"++-- * Class 0P — Invalid Role Specification+-------------------------++invalid_role_specification :: ErrorCode = "0P000"++-- * Class 0Z — Diagnostics Exception+-------------------------++diagnostics_exception :: ErrorCode = "0Z000"+stacked_diagnostics_accessed_without_active_handler :: ErrorCode = "0Z002"++-- * Class 20 — Case Not Found+-------------------------++case_not_found :: ErrorCode = "20000"++-- * Class 21 — Cardinality Violation+-------------------------++cardinality_violation :: ErrorCode = "21000"++-- * Class 22 — Data Exception+-------------------------++data_exception :: ErrorCode = "22000"+array_subscript_error :: ErrorCode = "2202E"+character_not_in_repertoire :: ErrorCode = "22021"+datetime_field_overflow :: ErrorCode = "22008"+division_by_zero :: ErrorCode = "22012"+error_in_assignment :: ErrorCode = "22005"+escape_character_conflict :: ErrorCode = "2200B"+indicator_overflow :: ErrorCode = "22022"+interval_field_overflow :: ErrorCode = "22015"+invalid_argument_for_logarithm :: ErrorCode = "2201E"+invalid_argument_for_ntile_function :: ErrorCode = "22014"+invalid_argument_for_nth_value_function :: ErrorCode = "22016"+invalid_argument_for_power_function :: ErrorCode = "2201F"+invalid_argument_for_width_bucket_function :: ErrorCode = "2201G"+invalid_character_value_for_cast :: ErrorCode = "22018"+invalid_datetime_format :: ErrorCode = "22007"+invalid_escape_character :: ErrorCode = "22019"+invalid_escape_octet :: ErrorCode = "2200D"+invalid_escape_sequence :: ErrorCode = "22025"+nonstandard_use_of_escape_character :: ErrorCode = "22P06"+invalid_indicator_parameter_value :: ErrorCode = "22010"+invalid_parameter_value :: ErrorCode = "22023"+invalid_regular_expression :: ErrorCode = "2201B"+invalid_row_count_in_limit_clause :: ErrorCode = "2201W"+invalid_row_count_in_result_offset_clause :: ErrorCode = "2201X"+invalid_time_zone_displacement_value :: ErrorCode = "22009"+invalid_use_of_escape_character :: ErrorCode = "2200C"+most_specific_type_mismatch :: ErrorCode = "2200G"+null_value_not_allowed :: ErrorCode = "22004"+null_value_no_indicator_parameter :: ErrorCode = "22002"+numeric_value_out_of_range :: ErrorCode = "22003"+string_data_length_mismatch :: ErrorCode = "22026"+string_data_right_truncation' :: ErrorCode = "22001"+substring_error :: ErrorCode = "22011"+trim_error :: ErrorCode = "22027"+unterminated_c_string :: ErrorCode = "22024"+zero_length_character_string :: ErrorCode = "2200F"+floating_point_exception :: ErrorCode = "22P01"+invalid_text_representation :: ErrorCode = "22P02"+invalid_binary_representation :: ErrorCode = "22P03"+bad_copy_file_format :: ErrorCode = "22P04"+untranslatable_character :: ErrorCode = "22P05"+not_an_xml_document :: ErrorCode = "2200L"+invalid_xml_document :: ErrorCode = "2200M"+invalid_xml_content :: ErrorCode = "2200N"+invalid_xml_comment :: ErrorCode = "2200S"+invalid_xml_processing_instruction :: ErrorCode = "2200T"++-- * Class 23 — Integrity Constraint Violation+-------------------------++integrity_constraint_violation :: ErrorCode = "23000"+restrict_violation :: ErrorCode = "23001"+not_null_violation :: ErrorCode = "23502"+foreign_key_violation :: ErrorCode = "23503"+unique_violation :: ErrorCode = "23505"+check_violation :: ErrorCode = "23514"+exclusion_violation :: ErrorCode = "23P01"++-- * Class 24 — Invalid Cursor State+-------------------------++invalid_cursor_state :: ErrorCode = "24000"++-- * Class 25 — Invalid Transaction State+-------------------------++invalid_transaction_state :: ErrorCode = "25000"+active_sql_transaction :: ErrorCode = "25001"+branch_transaction_already_active :: ErrorCode = "25002"+held_cursor_requires_same_isolation_level :: ErrorCode = "25008"+inappropriate_access_mode_for_branch_transaction :: ErrorCode = "25003"+inappropriate_isolation_level_for_branch_transaction :: ErrorCode = "25004"+no_active_sql_transaction_for_branch_transaction :: ErrorCode = "25005"+read_only_sql_transaction :: ErrorCode = "25006"+schema_and_data_statement_mixing_not_supported :: ErrorCode = "25007"+no_active_sql_transaction :: ErrorCode = "25P01"+in_failed_sql_transaction :: ErrorCode = "25P02"++-- * Class 26 — Invalid SQL Statement Name+-------------------------++invalid_sql_statement_name :: ErrorCode = "26000"++-- * Class 27 — Triggered Data Change Violation+-------------------------++triggered_data_change_violation :: ErrorCode = "27000"++-- * Class 28 — Invalid Authorization Specification+-------------------------++invalid_authorization_specification :: ErrorCode = "28000"+invalid_password :: ErrorCode = "28P01"++-- * Class 2B — Dependent Privilege Descriptors Still Exist+-------------------------++dependent_privilege_descriptors_still_exist :: ErrorCode = "2B000"+dependent_objects_still_exist :: ErrorCode = "2BP01"++-- * Class 2D — Invalid Transaction Termination+-------------------------++invalid_transaction_termination :: ErrorCode = "2D000"++-- * Class 2F — SQL Routine Exception+-------------------------++sql_routine_exception :: ErrorCode = "2F000"+function_executed_no_return_statement :: ErrorCode = "2F005"+modifying_sql_data_not_permitted :: ErrorCode = "2F002"+prohibited_sql_statement_attempted :: ErrorCode = "2F003"+reading_sql_data_not_permitted :: ErrorCode = "2F004"++-- * Class 34 — Invalid Cursor Name+-------------------------++invalid_cursor_name :: ErrorCode = "34000"++-- * Class 38 — External Routine Exception+-------------------------++external_routine_exception :: ErrorCode = "38000"+containing_sql_not_permitted :: ErrorCode = "38001"+modifying_sql_data_not_permitted' :: ErrorCode = "38002"+prohibited_sql_statement_attempted' :: ErrorCode = "38003"+reading_sql_data_not_permitted' :: ErrorCode = "38004"++-- * Class 39 — External Routine Invocation Exception+-------------------------++external_routine_invocation_exception :: ErrorCode = "39000"+invalid_sqlstate_returned :: ErrorCode = "39001"+null_value_not_allowed' :: ErrorCode = "39004"+trigger_protocol_violated :: ErrorCode = "39P01"+srf_protocol_violated :: ErrorCode = "39P02"++-- * Class 3B — Savepoint Exception+-------------------------++savepoint_exception :: ErrorCode = "3B000"+invalid_savepoint_specification :: ErrorCode = "3B001"++-- * Class 3D — Invalid Catalog Name+-------------------------++invalid_catalog_name :: ErrorCode = "3D000"++-- * Class 3F — Invalid Schema Name+-------------------------++invalid_schema_name :: ErrorCode = "3F000"++-- * Class 40 — Transaction Rollback+-------------------------++transaction_rollback :: ErrorCode = "40000"+transaction_integrity_constraint_violation :: ErrorCode = "40002"+serialization_failure :: ErrorCode = "40001"+statement_completion_unknown :: ErrorCode = "40003"+deadlock_detected :: ErrorCode = "40P01"++-- * Class 42 — Syntax Error or Access Rule Violation+-------------------------++syntax_error_or_access_rule_violation :: ErrorCode = "42000"+syntax_error :: ErrorCode = "42601"+insufficient_privilege :: ErrorCode = "42501"+cannot_coerce :: ErrorCode = "42846"+grouping_error :: ErrorCode = "42803"+windowing_error :: ErrorCode = "42P20"+invalid_recursion :: ErrorCode = "42P19"+invalid_foreign_key :: ErrorCode = "42830"+invalid_name :: ErrorCode = "42602"+name_too_long :: ErrorCode = "42622"+reserved_name :: ErrorCode = "42939"+datatype_mismatch :: ErrorCode = "42804"+indeterminate_datatype :: ErrorCode = "42P18"+collation_mismatch :: ErrorCode = "42P21"+indeterminate_collation :: ErrorCode = "42P22"+wrong_object_type :: ErrorCode = "42809"+undefined_column :: ErrorCode = "42703"+undefined_function :: ErrorCode = "42883"+undefined_table :: ErrorCode = "42P01"+undefined_parameter :: ErrorCode = "42P02"+undefined_object :: ErrorCode = "42704"+duplicate_column :: ErrorCode = "42701"+duplicate_cursor :: ErrorCode = "42P03"+duplicate_database :: ErrorCode = "42P04"+duplicate_function :: ErrorCode = "42723"+duplicate_prepared_statement :: ErrorCode = "42P05"+duplicate_schema :: ErrorCode = "42P06"+duplicate_table :: ErrorCode = "42P07"+duplicate_alias :: ErrorCode = "42712"+duplicate_object :: ErrorCode = "42710"+ambiguous_column :: ErrorCode = "42702"+ambiguous_function :: ErrorCode = "42725"+ambiguous_parameter :: ErrorCode = "42P08"+ambiguous_alias :: ErrorCode = "42P09"+invalid_column_reference :: ErrorCode = "42P10"+invalid_column_definition :: ErrorCode = "42611"+invalid_cursor_definition :: ErrorCode = "42P11"+invalid_database_definition :: ErrorCode = "42P12"+invalid_function_definition :: ErrorCode = "42P13"+invalid_prepared_statement_definition :: ErrorCode = "42P14"+invalid_schema_definition :: ErrorCode = "42P15"+invalid_table_definition :: ErrorCode = "42P16"+invalid_object_definition :: ErrorCode = "42P17"++-- * Class 44 — WITH CHECK OPTION Violation+-------------------------++with_check_option_violation :: ErrorCode = "44000"++-- * Class 53 — Insufficient Resources+-------------------------++insufficient_resources :: ErrorCode = "53000"+disk_full :: ErrorCode = "53100"+out_of_memory :: ErrorCode = "53200"+too_many_connections :: ErrorCode = "53300"+configuration_limit_exceeded :: ErrorCode = "53400"++-- * Class 54 — Program Limit Exceeded+-------------------------++program_limit_exceeded :: ErrorCode = "54000"+statement_too_complex :: ErrorCode = "54001"+too_many_columns :: ErrorCode = "54011"+too_many_arguments :: ErrorCode = "54023"++-- * Class 55 — Object Not In Prerequisite State+-------------------------++object_not_in_prerequisite_state :: ErrorCode = "55000"+object_in_use :: ErrorCode = "55006"+cant_change_runtime_param :: ErrorCode = "55P02"+lock_not_available :: ErrorCode = "55P03"++-- * Class 57 — Operator Intervention+-------------------------++operator_intervention :: ErrorCode = "57000"+query_canceled :: ErrorCode = "57014"+admin_shutdown :: ErrorCode = "57P01"+crash_shutdown :: ErrorCode = "57P02"+cannot_connect_now :: ErrorCode = "57P03"+database_dropped :: ErrorCode = "57P04"++-- * Class 58 — System Error (errors external to PostgreSQL itself)+-------------------------++system_error :: ErrorCode = "58000"+io_error :: ErrorCode = "58030"+undefined_file :: ErrorCode = "58P01"+duplicate_file :: ErrorCode = "58P02"++-- * Class F0 — Configuration File Error+-------------------------++config_file_error :: ErrorCode = "F0000"+lock_file_exists :: ErrorCode = "F0001"++-- * Class HV — Foreign Data Wrapper Error (SQL/MED)+-------------------------++fdw_error :: ErrorCode = "HV000"+fdw_column_name_not_found :: ErrorCode = "HV005"+fdw_dynamic_parameter_value_needed :: ErrorCode = "HV002"+fdw_function_sequence_error :: ErrorCode = "HV010"+fdw_inconsistent_descriptor_information :: ErrorCode = "HV021"+fdw_invalid_attribute_value :: ErrorCode = "HV024"+fdw_invalid_column_name :: ErrorCode = "HV007"+fdw_invalid_column_number :: ErrorCode = "HV008"+fdw_invalid_data_type :: ErrorCode = "HV004"+fdw_invalid_data_type_descriptors :: ErrorCode = "HV006"+fdw_invalid_descriptor_field_identifier :: ErrorCode = "HV091"+fdw_invalid_handle :: ErrorCode = "HV00B"+fdw_invalid_option_index :: ErrorCode = "HV00C"+fdw_invalid_option_name :: ErrorCode = "HV00D"+fdw_invalid_string_length_or_buffer_length :: ErrorCode = "HV090"+fdw_invalid_string_format :: ErrorCode = "HV00A"+fdw_invalid_use_of_null_pointer :: ErrorCode = "HV009"+fdw_too_many_handles :: ErrorCode = "HV014"+fdw_out_of_memory :: ErrorCode = "HV001"+fdw_no_schemas :: ErrorCode = "HV00P"+fdw_option_name_not_found :: ErrorCode = "HV00J"+fdw_reply_handle :: ErrorCode = "HV00K"+fdw_schema_not_found :: ErrorCode = "HV00Q"+fdw_table_not_found :: ErrorCode = "HV00R"+fdw_unable_to_create_execution :: ErrorCode = "HV00L"+fdw_unable_to_create_reply :: ErrorCode = "HV00M"+fdw_unable_to_establish_connection :: ErrorCode = "HV00N"++-- * Class P0 — PL/pgSQL Error+-------------------------++plpgsql_error :: ErrorCode = "P0000"+raise_exception :: ErrorCode = "P0001"+no_data_found :: ErrorCode = "P0002"+too_many_rows :: ErrorCode = "P0003"++-- * Class XX — Internal Error+-------------------------++internal_error :: ErrorCode = "XX000"+data_corrupted :: ErrorCode = "XX001"+index_corrupted :: ErrorCode = "XX002"
+ library/Hasql/Postgres/OID.hs view
@@ -0,0 +1,54 @@+module Hasql.Postgres.OID where++import Database.PostgreSQL.LibPQ (Oid(..))+++type OID = Oid++abstime = Oid 702+bit = Oid 1560+bool = Oid 16+box = Oid 603+bpchar = Oid 1042+bytea = Oid 17+char = Oid 18+cid = Oid 29+cidr = Oid 650+circle = Oid 718+date = Oid 1082+float4 = Oid 700+float8 = Oid 701+inet = Oid 869+int2 = Oid 21+int4 = Oid 23+int8 = Oid 20+interval = Oid 1186+json = Oid 114+line = Oid 628+lseg = Oid 601+macaddr = Oid 829+money = Oid 790+name = Oid 19+numeric = Oid 1700+oid = Oid 26+path = Oid 602+point = Oid 600+polygon = Oid 604+record = Oid 2249+refcursor = Oid 1790+regproc = Oid 24+reltime = Oid 703+text = Oid 25+tid = Oid 27+time = Oid 1083+timestamp = Oid 1114+timestamptz = Oid 1184+timetz = Oid 1266+tinterval = Oid 704+unknown = Oid 705+uuid = Oid 2950+varbit = Oid 1562+varchar = Oid 1043+void = Oid 2278+xid = Oid 28+xml = Oid 142
+ library/Hasql/Postgres/Parser.hs view
@@ -0,0 +1,144 @@+module Hasql.Postgres.Parser where++import Hasql.Postgres.Prelude hiding (take)+import Data.Attoparsec.ByteString+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Encoding+++type P = Parser++run :: ByteString -> P a -> Either Text a+run input parser =+ left fromString $ parseOnly (parser <* endOfInput) input+++-- ** Parser+-------------------------++labeling :: String -> Parser a -> Parser a+labeling n p = + p <?> n++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 ((Hasql.Postgres.Prelude.bool negate id p) (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 ((Hasql.Postgres.Prelude.bool negate id p) (60 * h + m))++utcTime :: P UTCTime+utcTime =+ UTCTime <$> day <*> (charUnit ' ' *> diffTime)++diffTime :: P DiffTime+diffTime = timeOfDayToTime <$> timeOfDay
+ library/Hasql/Postgres/Prelude.hs view
@@ -0,0 +1,76 @@+module Hasql.Postgres.Prelude+( + module Exports,+ bug,+ bottom,+ partial,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports++-- mtl-prelude+-------------------------+import MTLPrelude as Exports hiding (shift)++-- mmorph+-------------------------+import Control.Monad.Morph as Exports++-- list-t+-------------------------+import ListT as Exports (ListT)++-- hashable+-------------------------+import Data.Hashable as Exports (Hashable(..))++-- text+-------------------------+import Data.Text as Exports (Text)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- decimal+-------------------------+import Data.Decimal as Exports (Decimal, DecimalRaw)++-- scientific+-------------------------+import Data.Scientific as Exports (Scientific)++-- time+-------------------------+import Data.Time as Exports++-- old-locale+-------------------------+import System.Locale as Exports++-- vector+-------------------------+import Data.Vector as Exports (Vector)++-- placeholders+-------------------------+import Development.Placeholders as Exports++-- custom+-------------------------+import qualified Debug.Trace.LocationTH+++bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]+ where+ msg = "A \"hasql-postgres\" package bug: " :: String++bottom = [e| $bug "Bottom evaluated" |]++partial :: Alternative f => (a -> Bool) -> a -> f a+partial p x = + if p x then pure x else empty
+ library/Hasql/Postgres/Renderer.hs view
@@ -0,0 +1,162 @@+-- |+-- 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.Builder as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Builder.Scientific+++-- | A renderer of @a@.+type R a =+ a -> B.Builder++run :: a -> R a -> ByteString+run a f =+ (L.toStrict . B.toLazyByteString . f) a+++-- ** Renderer+-------------------------++ascii :: Show a => R a+ascii =+ B.string7 . show+++-- *** strings+-------------------------++char7 :: R Char = + B.char7++char :: R Char = + B.charUtf8++string7 :: R String = + B.string7++string :: R String = + B.string8++byteString :: R ByteString = + B.byteString++text :: R Text =+ byteString . T.encodeUtf8+++-- *** enumerations+-------------------------++bool :: R Bool =+ \b -> if b then word8 1 else word8 0++word8 :: R Word8 =+ B.word8Dec++word16 :: R Word16 =+ B.word16Dec++word32 :: R Word32 =+ B.word32Dec++word64 :: R Word64 =+ B.word64Dec++word :: R Word =+ B.wordDec++int8 :: R Int8 =+ B.int8Dec++int16 :: R Int16 =+ B.int16Dec++int32 :: R Int32 =+ B.int32Dec++int64 :: R Int64 =+ B.int64Dec++int :: R Int =+ B.intDec++integer :: R Integer =+ B.integerDec++paddedInt :: Int -> R Int+paddedInt padding n =+ if padding <= width+ then int n+ else mconcat (replicate (padding - width) (B.char7 '0')) <> int n+ where+ width = fromIntegral (succ (floor (logBase 10 (fromIntegral n))) :: Integer)+ ++-- *** fractionals+-------------------------++float :: R Float =+ B.floatDec+ +double :: R Double =+ B.doubleDec++decimalRawInt32 :: R (DecimalRaw Int32) =+ ascii++decimalRawInt64 :: R (DecimalRaw Int64) =+ ascii++decimalRawWord32 :: R (DecimalRaw Word32) =+ ascii++decimalRawWord64 :: R (DecimalRaw Word64) =+ ascii++decimal :: R Decimal =+ ascii++pico :: R Pico =+ B.string7 . showFixed True++scientific :: R Scientific =+ Data.ByteString.Builder.Scientific.scientificBuilder++-- *** time+-------------------------++day :: R Day = + B.string7 . formatTime defaultTimeLocale (iso8601DateFormat Nothing)++timeOfDay :: R TimeOfDay = + B.string7 . formatTime defaultTimeLocale "%T%Q"++localTime :: R LocalTime = + B.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)+ where+ hm h m = + paddedInt 2 h <> B.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"))++diffTime :: R DiffTime =+ pico . fromRational . toRational++nominalDiffTime :: R NominalDiffTime =+ pico . fromRational . toRational
+ library/Hasql/Postgres/ResultHandler.hs view
@@ -0,0 +1,75 @@+-- |+-- Backend-aware parsed results' handlers.+module Hasql.Postgres.ResultHandler where++import Hasql.Postgres.Prelude+import qualified Hasql.Backend as Backend+import qualified Hasql.Postgres.ResultParser as Result+import qualified Hasql.Postgres.ErrorCode as ErrorCode+++type ResultHandler a =+ Result.Result -> IO a++{-# INLINE unit #-}+unit :: ResultHandler ()+unit =+ resultHandler $ \case+ Result.CommandOK _ -> Right $ return ()+ _ -> Left "Not a unit"++{-# INLINE rowsStream #-}+rowsStream :: ResultHandler Result.RowsStream+rowsStream =+ resultHandler $ \case+ Result.Rows s _ _ -> Right s+ _ -> Left "Not a rows result"++{-# INLINE rowsVector #-}+rowsVector :: ResultHandler Result.RowsVector+rowsVector =+ resultHandler $ \case+ Result.Rows _ v _ -> Right v+ _ -> Left "Not a rows result"++{-# INLINE rowsList #-}+rowsList :: ResultHandler Result.RowsList+rowsList =+ resultHandler $ \case+ Result.Rows _ _ l -> Right l+ _ -> Left "Not a rows result"++{-# INLINE rowsAffected #-}+rowsAffected :: ResultHandler ByteString+rowsAffected =+ resultHandler $ \case+ Result.CommandOK (Just v) -> Right $ return v+ _ -> Left "Not a number of affected rows"++{-# INLINE resultHandler #-}+resultHandler :: (Result.Result -> Either Text (IO a)) -> ResultHandler a+resultHandler partial result =+ case partial result of+ Right io -> + io+ Left text -> + -- Handle erroneous results with unexpected result as a fallback.+ case result of+ Result.StatusError _ c _ _ _ | elem c codes ->+ throwIO Backend.TransactionConflict+ where+ codes =+ [+ ErrorCode.transaction_rollback,+ ErrorCode.transaction_integrity_constraint_violation,+ ErrorCode.serialization_failure,+ ErrorCode.statement_completion_unknown,+ ErrorCode.deadlock_detected+ ]+ _ ->+ maybe+ (throwIO $ Backend.UnexpectedResult text)+ (throwIO . Backend.ErroneousResult)+ (Result.erroneousResultText result)++
+ library/Hasql/Postgres/ResultParser.hs view
@@ -0,0 +1,185 @@+module Hasql.Postgres.ResultParser+( + Result(..), + StatusErrorStatus(..),+ RowsStream(..),+ RowsVector(..),+ RowsList(..),+ parse,+ erroneousResultText,+)+where++import Hasql.Postgres.Prelude+import qualified Database.PostgreSQL.LibPQ as L+import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MVector+import qualified ListT+import qualified Data.Text.Encoding as Text+import qualified Data.Text as Text+++data Result =+ -- |+ -- Out-of-memory conditions or serious errors such as inability to send the command to the server.+ -- May contain some description.+ NoResult (Maybe ByteString) |+ -- |+ -- A failure with comprehensive description.+ -- + -- The fields are: status, code, message, detail, hint.+ StatusError StatusErrorStatus ByteString (Maybe ByteString) (Maybe ByteString) (Maybe ByteString) |+ -- |+ -- Command executed fine.+ -- + -- The fields are: a number of affected rows.+ CommandOK (Maybe ByteString) |+ -- |+ -- Command executed fine and returns rows.+ -- + -- The fields are generators of respective rows representations.+ Rows (IO RowsStream) (IO RowsVector) (IO RowsList)++data StatusErrorStatus =+ BadResponse | NonfatalError | FatalError+ deriving (Show, Typeable, Eq, Ord, Enum, Bounded)+++parse :: L.Connection -> Maybe L.Result -> IO Result+parse c =+ \case+ Nothing ->+ NoResult <$> L.errorMessage c+ Just r ->+ L.resultStatus r >>=+ \case+ L.CommandOk ->+ CommandOK <$> L.cmdTuples r+ L.TuplesOk ->+ return $ Rows <$> getRowsStream <*> getRowsVector <*> getRowsList $ r+ L.BadResponse ->+ statusError BadResponse+ L.NonfatalError ->+ statusError NonfatalError+ L.FatalError ->+ statusError FatalError+ r ->+ $bug $ "Unsupported result status: " <> show r+ where+ statusError s =+ StatusError s <$> state <*> message <*> detail <*> hint+ where+ state = fromJust <$> L.resultErrorField r L.DiagSqlstate+ message = L.resultErrorField r L.DiagMessagePrimary+ detail = L.resultErrorField r L.DiagMessageDetail+ hint = L.resultErrorField r L.DiagMessageHint+++{-# INLINE erroneousResultText #-}+erroneousResultText :: Result -> Maybe Text+erroneousResultText =+ \case+ NoResult (Just bs) -> + Just $ "Inable to send command to the server due to: " <> Text.decodeLatin1 bs+ NoResult Nothing -> + Just $ "Inable to send command to the server"+ StatusError status code message details hint ->+ Just $ + "A status error. " <> formatFields fields+ where+ formatFields = + formatList . map formatField . catMaybes+ where+ formatList items =+ Text.intercalate "; " items <> "."+ formatField (n, v) =+ n <> ": \"" <> v <> "\""+ fields =+ [+ Just ("Status", fromString $ show status),+ Just ("Code", Text.decodeLatin1 code),+ fmap (("Message",) . Text.decodeLatin1) $ message,+ fmap (("Details",) . Text.decodeLatin1) $ details,+ fmap (("Hint",) . Text.decodeLatin1) $ hint+ ]+ _ -> + Nothing++++-- * Rows processing+-------------------------++type Row =+ Vector (Maybe ByteString)+++type RowsStream =+ ListT IO Row++getRowsStream :: L.Result -> IO RowsStream+getRowsStream r =+ do+ nr <- L.ntuples r+ nc <- L.nfields r+ return $ + let+ loop ir = + if ir < nr+ then do + row <- + liftIO $ do+ mv <- MVector.new (colInt nc)+ forM_ [0..pred nc] $ \ic ->+ MVector.write mv (colInt ic) =<< L.getvalue r ir ic+ Vector.unsafeFreeze mv+ ListT.cons row (loop (succ ir))+ else mzero+ in + loop 0+++type RowsVector =+ Vector Row++getRowsVector :: L.Result -> IO RowsVector+getRowsVector r =+ do+ nr <- L.ntuples r+ nc <- L.nfields r+ mvx <- MVector.new (rowInt nr)+ forM_ [0..pred nr] $ \ir -> do+ mvy <- MVector.new (colInt nc)+ forM_ [0..pred nc] $ \ic -> do+ MVector.write mvy (colInt ic) =<< L.getvalue r ir ic+ vy <- Vector.unsafeFreeze mvy+ MVector.write mvx (rowInt ir) vy+ Vector.unsafeFreeze mvx+++type RowsList =+ [Row]++getRowsList :: L.Result -> IO RowsList+getRowsList r =+ do+ nr <- L.ntuples r+ nc <- L.nfields r+ mvx <- MVector.new (rowInt nr)+ forM [0..pred nr] $ \ir -> do+ mvy <- MVector.new (colInt nc)+ forM_ [0..pred nc] $ \ic -> do+ MVector.write mvy (colInt ic) =<< L.getvalue r ir ic+ Vector.unsafeFreeze mvy+++-- * Utils+-------------------------++{-# INLINE colInt #-}+colInt :: L.Column -> Int+colInt (L.Col n) = fromIntegral n++{-# INLINE rowInt #-}+rowInt :: L.Row -> Int+rowInt (L.Row n) = fromIntegral n
+ library/Hasql/Postgres/Statement.hs view
@@ -0,0 +1,90 @@+module Hasql.Postgres.Statement where++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+++type Statement =+ (ByteString, [(ValueType, Value)], Preparable)++-- |+-- Maybe a rendered value with its serialization format.+-- 'Nothing' implies @NULL@.+type Value = + Maybe (ByteString, L.Format)++type ValueType =+ L.Oid++type Preparable =+ Bool +++-- * Transaction types+-------------------------++type Cursor =+ ByteString++data Isolation =+ ReadCommitted |+ RepeatableRead |+ Serializable ++type TransactionMode =+ (Isolation, Bool)+++declareCursor :: Cursor -> Statement -> Statement+declareCursor cursor (template, values, preparable) =+ let+ template' =+ "DECLARE " <> cursor <> " NO SCROLL CURSOR FOR " <> template+ in (template', values, preparable)++closeCursor :: Cursor -> Statement+closeCursor cursor =+ (template, [], False)+ where+ template =+ Renderer.run cursor $ \c -> Renderer.string7 "CLOSE " <> Renderer.byteString c++fetchFromCursor :: Cursor -> Statement+fetchFromCursor cursor =+ (template, [], False)+ where+ template =+ Renderer.run cursor $ \c -> + Renderer.string7 "FETCH FORWARD 256 FROM " <> Renderer.byteString c++beginTransaction :: TransactionMode -> Statement+beginTransaction mode =+ (template, [], True)+ where+ template =+ Renderer.run mode $ \(i, w) ->+ mconcat $ intersperse (Renderer.char7 ' ') $+ [+ Renderer.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"+ ,+ case w of+ True -> "READ WRITE"+ False -> "READ ONLY"+ ]++commitTransaction :: Statement+commitTransaction =+ ("COMMIT", [], True)++abortTransaction :: Statement+abortTransaction =+ ("ABORT", [], True)++
+ library/Hasql/Postgres/StatementPreparer.hs view
@@ -0,0 +1,55 @@+-- |+-- A backend-aware component, which prepares statements.+module Hasql.Postgres.StatementPreparer where++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++++type StatementPreparer =+ (PQ.Connection, IORef Word16, Hashtables.BasicHashTable LocalKey RemoteKey)+++-- |+-- Local statement key.+data LocalKey =+ LocalKey !ByteString ![PQ.Oid]+ deriving (Show, Eq)++-- |+-- Optimized by ignoring the OIDs.+instance Hashable LocalKey where+ hashWithSalt s (LocalKey b _) = hashWithSalt s b+++-- |+-- Remote statement key.+type RemoteKey =+ ByteString+++new :: PQ.Connection -> IO StatementPreparer+new connection =+ (,,) <$> pure connection <*> newIORef 0 <*> Hashtables.new++prepare :: ByteString -> [PQ.Oid] -> StatementPreparer -> IO RemoteKey+prepare s tl (c, counter, table) =+ do+ let k = LocalKey s tl+ r <- Hashtables.lookup table k+ case r of+ Just r -> + return r+ Nothing ->+ do+ w <- readIORef counter+ n <- return (Renderer.run w Renderer.word16)+ ResultHandler.unit =<< Result.parse c =<< PQ.prepare c n s (partial (not . null) tl)+ Hashtables.insert table k n+ writeIORef counter (succ w)+ return n
+ library/Hasql/Postgres/TemplateConverter.hs view
@@ -0,0 +1,22 @@+module Hasql.Postgres.TemplateConverter where++import Hasql.Postgres.Prelude+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB+import qualified Hasql.Postgres.TemplateConverter.Parser as Parser+++convert :: ByteString -> Either Text ByteString+convert t =+ do+ parts <- Parser.run t Parser.parts+ return $+ BL.toStrict $ BB.toLazyByteString $ mconcat $ ($ 1) $ evalState $ do+ forM parts $ \case+ Parser.Chunk c -> do+ return c+ Parser.Placeholder -> do+ i <- get+ put $ succ i+ return $ BB.char8 '$' <> BB.wordDec i+
+ library/Hasql/Postgres/TemplateConverter/Parser.hs view
@@ -0,0 +1,39 @@+module Hasql.Postgres.TemplateConverter.Parser where++import Hasql.Postgres.Prelude+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB+++data Part =+ Chunk BB.Builder |+ Placeholder++run :: ByteString -> Parser a -> Either Text a+run input parser =+ left fromString $ parseOnly (parser <* endOfInput) input++parts :: Parser [Part]+parts =+ many (chunk <|> placeholder)+ where+ chunk = + fmap Chunk $ fmap mconcat $ many1 $ stringLit <|> (BB.char8 <$> notChar '?')+ placeholder = + char '?' *> pure Placeholder++stringLit :: Parser BB.Builder+stringLit =+ do+ quote <- + char '"' <|> char '\''+ contentBuilders <- + many $ + (BB.byteString <$> string "\\\\") <|> + (BB.byteString <$> string (fromString ['\\', quote])) <|> + (BB.char8 <$> notChar quote)+ char quote+ return $+ BB.char7 quote <> mconcat contentBuilders <> BB.char7 quote+
+ profiling/Main.hs view
@@ -0,0 +1,36 @@+import BasePrelude+import MTLPrelude+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Time+import qualified Hasql as H+import qualified Hasql.Postgres as H+import qualified ListT+import qualified Test.QuickCheck.Gen as Q+import qualified Test.QuickCheck.Arbitrary as Q+import qualified Test.QuickCheck.Instances+++main = do+ rows :: [(Text, Day)] <- + liftIO $ replicateM 100 $ + (,) <$> Q.generate Q.arbitrary <*> Q.generate Q.arbitrary+ H.session (H.Postgres host port user password db) (fromJust $ H.sessionSettings 1 30) $ do+ H.tx Nothing $ do+ H.unit [H.q|DROP TABLE IF EXISTS a|]+ H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE, + PRIMARY KEY (id))|]+ forM_ rows $ \(name, birthday) -> do+ H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday+ replicateM_ 2000 $ do+ H.tx Nothing $ do+ H.list $ [H.q|SELECT * FROM a|] :: H.Tx H.Postgres s [(Int, Text, Day)]+++host = "localhost"+port = 5432+user = "postgres"+password = ""+db = "postgres"
+ tests/Main.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import BasePrelude hiding (assert)+import MTLPrelude+import Test.Framework+import Test.QuickCheck.Instances+import Hasql+import Hasql.Postgres (Postgres(..))+import Data.Text (Text)+import Data.Time+import qualified Data.Text+import qualified ListT+import qualified SlaveThread+import qualified Control.Concurrent.SSem as SSem+import qualified Hasql.Backend as Backend+import qualified Hasql as H+import qualified Hasql.Postgres as H+++main = + htfMain $ htf_thisModulesTests+++test_rendering =+ assertEqual (Just $ head rows) =<< do + session1 $ do+ H.tx Nothing $ do+ H.unit [H.q|DROP TABLE IF EXISTS a|]+ H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday INT8,+ PRIMARY KEY (id))|]+ forM_ rows $ \(name, birthday) -> do+ H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday+ H.tx Nothing $ do+ H.single $ [H.q|SELECT name, birthday FROM a WHERE id = ? |] (1 :: Int)+ where+ rows = [("A", 34525), ("B", 324987)] :: [(Text, Int)]++test_countEffects =+ unitTestPending ""++test_autoIncrement =+ assertEqual (Just (1 :: Word64), Just (2 :: Word64)) =<< do+ session1 $ tx Nothing $ do+ unit [q|DROP TABLE IF EXISTS a|]+ unit [q|CREATE TABLE a (id SERIAL NOT NULL, v INT8, PRIMARY KEY (id))|]+ id1 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (1) RETURNING id|]+ id2 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (2) RETURNING id|]+ return (id1, id2)++test_transactionConflictResolution =+ do+ session1 $ tx Nothing $ do+ unit [q|DROP TABLE IF EXISTS a|]+ unit [q|CREATE TABLE a ("id" int8, "v" int8, PRIMARY KEY ("id"))|]+ unit [q|INSERT INTO a (id, v) VALUES ('7', '0')|]+ semaphore <- SSem.new (-1)+ SlaveThread.fork $ session >> SSem.signal semaphore+ SlaveThread.fork $ session >> SSem.signal semaphore+ SSem.wait semaphore+ r <- session1 $ tx Nothing $ single [q|SELECT v FROM a WHERE id='7'|]+ assertEqual (Just (Identity (200 :: Int))) r+ where+ session =+ session1 $ do+ replicateM 100 $ tx (Just (Serializable, True)) $ do+ Just (Identity (v :: Int)) <- single [q|SELECT v FROM a WHERE id='7'|]+ unit $ [q|UPDATE a SET v=? WHERE id='7'|] (succ v)++test_transaction =+ unitTestPending ""++test_cursorResultsOrder =+ session1 $ do+ r :: [Word] <-+ tx (Just (ReadCommitted, False)) $ do+ ListT.toList $ fmap runIdentity $ stream $ + [q|select oid from pg_type ORDER BY oid|]+ liftIO $ assertEqual (sort r) r++test_cursor =+ session1 $ do+ r :: [(Word, Text)] <-+ tx (Just (ReadCommitted, False)) $ do+ ListT.toList $ stream $+ [q|select oid, typname from pg_type|]+ r' :: [(Word, Text)] <-+ tx (Just (ReadCommitted, False)) $ do+ list $ [q|select oid, typname from pg_type|]+ liftIO $ assertEqual r' r++test_select =+ session1 $ do+ r :: [(Word, Text)] <-+ tx Nothing $ do+ list $ [q|select oid, typname from pg_type|]+ liftIO $ assertNotEqual [] r++test_mappingOfMaybe =+ session1 $ do+ validMappingSession (Just '!')+ validMappingSession (Nothing :: Maybe Bool)++test_mappingOfBool =+ session1 $ do+ validMappingSession True+ validMappingSession False++test_mappingOfUTF8Char =+ session1 $ do+ validMappingSession 'Й'++-- Postgres does not allow the '/NUL' character in text data+prop_mappingOfChar (v :: Char) =+ (v /= '\NUL') ==>+ Just v === do unsafePerformIO $ session1 $ selectSelf 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++prop_mappingOfInt (v :: Int) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfInt8 (v :: Int8) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfInt16 (v :: Int16) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfInt32 (v :: Int32) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfInt64 (v :: Int64) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfWord (v :: Word) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfWord8 (v :: Word8) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfWord16 (v :: Word16) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfWord32 (v :: Word32) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfWord64 (v :: Word64) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfDay (v :: Day) =+ Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfTimeOfDay (v :: TimeOfDay) =+ forAll microsTimeOfDayGen $ \v -> + Just v === do unsafePerformIO $ session1 $ selectSelf v++prop_mappingOfLocalTime =+ forAll microsLocalTimeGen $ \v -> + Just v === do unsafePerformIO $ session1 $ selectSelf 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 ->+ Just v === do unsafePerformIO $ session1 $ selectSelf v+ where+ gen = UTCTime <$> arbitrary <*> microsDiffTimeGen++microsTimeOfDayGen :: Gen TimeOfDay+microsTimeOfDayGen =+ timeToTimeOfDay <$> microsDiffTimeGen++microsLocalTimeGen :: Gen LocalTime+microsLocalTimeGen = + LocalTime <$> arbitrary <*> microsTimeOfDayGen++microsDiffTimeGen :: Gen DiffTime+microsDiffTimeGen = do+ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ choose (0, (10^6)*24*60*60)++selectSelf :: + Backend.Mapping Postgres a => Typeable a => + a -> Session Postgres IO (Maybe a)+selectSelf v =+ tx Nothing $ (fmap . fmap) runIdentity $ single $ [q| SELECT ? |] v++validMappingSession :: + Backend.Mapping Postgres a => Typeable a => Show a => Eq a => + a -> Session Postgres IO ()+validMappingSession v =+ selectSelf v >>= liftIO . assertEqual (Just v)++session1 :: Session Postgres IO r -> IO r+session1 =+ session backendSettings poolSettings+ where+ backendSettings = Postgres "localhost" 5432 "postgres" "" "postgres"+ poolSettings = fromJust $ sessionSettings 6 30