diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,36 +0,0 @@ -# 0.7.3.1 -* Attoparsec-0.13 support - -# 0.7.3 -* GHC 7.10 support - -# 0.7.2 -* Implement support for free variables by the quasi-quoter - -# 0.7.1 -* Relaxed the dependency on "monad-control" - -# 0.7.0 - Refinements and minor updates -* Streaming now is parameterized by the size of a chunk -* Introduced a new type `Ex` -* Changed the suffix of statement execution functions to `Ex` - -# 0.6.0 - Major API overhaul -* The connection pool acquisition is now explicit and is no longer handled by the `Session` monad. This should provide for a simpler integration with other libraries. -* The `Session` monad is now merely a convenience thing for providing a context to multiple transactions. One can run it as many times as he wants - it won't reestablish any resources any more. -* The connection timeout is now set using `Int` for simplicity. -* There are no exceptions any more. All the error-reporting is typed and done explicitly, using `Either`. -* The error types are now mostly backend-specific. -* The transaction mode is now extended to support uncommittable transactions with the `TxWriteMode` type. -* All `Tx` functions are now appended with a "Tx" suffix. -* Added `vectorTx` and `maybeTx` and updated the semantics of `singleTx`. -* `q` statement quasi-quoter is now renamed to more meaningful `stmt`. -* The `Statement` type is renamed to `Stmt` and is now exported from the main API. -* `RowParser` is now uninstantiable. This enforces the idiomatic usage of the library. -* Statement templates now support UTF-8. - -# 0.5.0 -* Update the "list-t" and "monad-control" deps - -# 0.4.1 -* Fix the transaction conflicts bug diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,52 @@ +module Main where + +import Main.Prelude +import Criterion.Main +import qualified Hasql.Connection as HC +import qualified Hasql.Settings as HS +import qualified Hasql.Query as HQ +import qualified Hasql.Encoding as HE +import qualified Hasql.Decoding as HD +import qualified Main.Queries as Q + + +main = + HC.acquire settings >>= either (fail . show) use + where + settings = + HS.settings host port user password database + where + host = "localhost" + port = 5432 + user = "postgres" + password = "" + database = "postgres" + use connection = + defaultMain + [ + bgroup "decoding" + [ + bgroup "1 column" + [ + bench "1 row" $ nfIO $! query () $! Q.select1 1 + , + bench "100 rows" $ nfIO $! query () $! Q.select1 100 + , + bench "10000 rows" $ nfIO $! query () $! Q.select1 10000 + ] + , + bgroup "4 columns" + [ + bench "1 row" $ nfIO $! query () $! Q.select4 1 + , + bench "100 rows" $ nfIO $! query () $! Q.select4 100 + , + bench "10000 rows" $ nfIO $! query () $! Q.select4 10000 + ] + ] + ] + where + query :: a -> HQ.Query a b -> IO b + query params query = + {-# SCC "query" #-} + HQ.run query params connection >>= either (fail . show) pure diff --git a/benchmark/Main/Prelude.hs b/benchmark/Main/Prelude.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main/Prelude.hs @@ -0,0 +1,77 @@ +module Main.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) + +-- transformers +------------------------- +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Data.Functor.Identity as Exports + +-- data-default-class +------------------------- +import Data.Default.Class as Exports + +-- profunctors +------------------------- +import Data.Profunctor.Unsafe as Exports + +-- contravariant +------------------------- +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports + +-- contravariant-extras +------------------------- +import Contravariant.Extras as Exports + +-- either +------------------------- +import Control.Monad.Trans.Either as Exports +import Data.Either.Combinators as Exports + +-- hashable +------------------------- +import Data.Hashable as Exports (Hashable(..)) + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +-- uuid +------------------------- +import Data.UUID as Exports (UUID) + +-- time +------------------------- +import Data.Time as Exports + +-- vector +------------------------- +import Data.Vector as Exports (Vector) + +-- dlist +------------------------- +import Data.DList as Exports (DList) + +-- deepseq +------------------------- +import Control.DeepSeq as Exports (NFData(..), force, deepseq, ($!!)) diff --git a/benchmark/Main/Queries.hs b/benchmark/Main/Queries.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main/Queries.hs @@ -0,0 +1,29 @@ +module Main.Queries where + +import Main.Prelude +import qualified Hasql.Query as HQ +import qualified Hasql.Encoding as HE +import qualified Hasql.Decoding as HD + + +select1 :: Int -> HQ.Query () (Vector Int64) +select1 amount = + {-# SCC "select1" #-} + HQ.Query sql mempty decoder True + where + !sql = + "values " <> + mconcat (intersperse ", " (replicate amount "(1)")) + decoder = + HD.rowsVector (HD.value HD.int8) + +select4 :: Int -> HQ.Query () (Vector (Int64, Int64, Int64, Int64)) +select4 amount = + {-# SCC "select4" #-} + HQ.Query sql mempty decoder True + where + !sql = + "values " <> + mconcat (intersperse ", " (replicate amount "(1, 2, 3, 4)")) + decoder = + HD.rowsVector ((,,,) <$> HD.value HD.int8 <*> HD.value HD.int8 <*> HD.value HD.int8 <*> HD.value HD.int8) diff --git a/demo/Main.hs b/demo/Main.hs deleted file mode 100644 --- a/demo/Main.hs +++ /dev/null @@ -1,77 +0,0 @@ --- You can execute this file with 'cabal bench demo'. -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} - -import Control.Monad hiding (forM_, mapM_, forM, mapM) -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Data.Functor.Identity -import Data.Foldable - --- Import the API from the "hasql" library -import qualified Hasql as H - --- Import the backend API from the "hasql-postgres" library -import qualified Hasql.Postgres as HP - - -main = do - - let postgresSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres" - - -- Prepare the pool settings with a smart constructor, - -- which checks the inputted values on correctness. - -- Set the connection pool size to 6 and the timeout to 30 seconds. - poolSettings <- maybe (fail "Improper session settings") return $ - H.poolSettings 6 30 - - -- Acquire the database connections pool. - -- Gotta help the compiler with the type signature of the pool a bit. - pool :: H.Pool HP.Postgres - <- H.acquirePool postgresSettings poolSettings - - -- Provide a context for execution of transactions. - -- 'Session' is merely a convenience wrapper around 'ReaderT'. - H.session pool $ do - - -- Execute a group of statements without any locking and ACID guarantees: - H.tx Nothing $ do - H.unitEx [H.stmt|DROP TABLE IF EXISTS a|] - H.unitEx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|] - -- Insert three rows: - replicateM_ 3 $ do - H.unitEx [H.stmt|INSERT INTO a (balance) VALUES (0)|] - - -- Declare a list of transfer settings, which we'll later use. - -- The tuple structure is: - -- @(withdrawalAccountID, arrivalAccountID, amount)@ - let transfers :: [(Int, Int, Int)] = - [(1, 2, 20), (2, 1, 30), (2, 3, 100)] - - forM_ transfers $ \(id1, id2, amount) -> do - -- Run a transaction with ACID guarantees. - -- Hasql will automatically roll it back and retry it in case of conflicts. - H.tx (Just (H.Serializable, (Just True))) $ do - -- Use MaybeT to handle empty results: - runMaybeT $ do - -- To distinguish results rows containing just one column, - -- we use 'Identity' as a sort of a single element tuple. - Identity balance1 <- MaybeT $ H.maybeEx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id1 - Identity balance2 <- MaybeT $ H.maybeEx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id2 - lift $ H.unitEx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1 - lift $ H.unitEx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance2 + amount) id2 - - -- Output all the updated rows: - do - -- Unfortunately in this case there's no way to infer the type of the results, - -- so we need to specify it explicitly: - rows <- H.tx Nothing $ H.vectorEx $ [H.stmt|SELECT * FROM a|] - forM_ rows $ \(id :: Int, amount :: Int) -> do - liftIO $ putStrLn $ "ID: " ++ show id ++ ", Amount: " ++ show amount - - -- Release all previously acquired resources. Just for fun. - H.releasePool pool - - - - diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -1,53 +1,15 @@ name: hasql version: - 0.7.4 + 0.14.0.2 +category: + Hasql, Database, PostgreSQL synopsis: - A minimalistic general high level API for relational databases + A very efficient PostgreSQL driver and a flexible mapping API description: - A robust and concise yet powerful API for communication with arbitrary - relational databases using SQL. - . - Features: - . - * Concise and crisp API. Just a few functions and two monads doing all the - boilerplate job for you. - . - * A powerful transaction abstraction, which provides - an automated resolution of conflicts. - The API ensures that you're only able to perform a specific - set of actions in the transaction context, - which allows Hasql to safely resolve conflicting transactions - by automatically retrying them. - This is much inspired by STM and ST. - . - * Support for cursors. Allows to fetch virtually limitless result sets in a - constant memory using streaming. - . - * Employment of prepared statements. - Every statement you emit gets prepared and cached. - This raises the performance of the backend. - . - * Automated management of resources related to connections, transactions and - cursors. - . - * A built-in connection pool. - . - * Compile-time generation of templates. You just can't write a statement with an - incorrect number of placeholders. - . - * Ability to map to any types actually supported by the backend. - . - Links: - . - * . - . - * . - . - * . + This package is the root of the \"hasql\" ecosystem. . -category: - Database + The API is completely disinfected from exceptions. All error-reporting is explicit and is presented using the 'Either' type. homepage: https://github.com/nikita-volkov/hasql bug-reports: @@ -66,8 +28,6 @@ Simple cabal-version: >=1.10 -extra-source-files: - CHANGELOG.md source-repository head @@ -81,123 +41,155 @@ 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 + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, 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.Prelude - Hasql.QQ.Parser - Hasql.CxRow - Hasql.TH - Hasql.QQ + Hasql.PTI + Hasql.IO + Hasql.Commands + Hasql.Decoding.Array + Hasql.Decoding.Composite + Hasql.Decoding.Value + Hasql.Decoding.Row + Hasql.Decoding.Result + Hasql.Decoding.Results + Hasql.Encoding.Array + Hasql.Encoding.Value + Hasql.Encoding.Params + Hasql.PreparedStatementRegistry + Hasql.Connection.Impl exposed-modules: - Hasql + Hasql.Decoding + Hasql.Encoding + Hasql.Settings + Hasql.Connection + Hasql.Query build-depends: - -- - resource-pool == 0.2.*, - hasql-backend == 0.4.*, - -- - template-haskell >= 2.8 && < 2.11, - -- + -- parsing: attoparsec >= 0.10 && < 0.14, - -- - vector < 0.12, - text >= 1.0 && < 1.3, - -- - either >= 4.3 && < 5, - list-t >= 0.3.1 && < 0.5, - mmorph == 1.0.*, - mtl >= 2.1 && < 2.3, - monad-control >= 0.3 && < 1.1, - transformers-base == 0.4.*, + -- database: + postgresql-binary >= 0.7.3 && < 0.8, + postgresql-libpq == 0.9.*, + -- data: + dlist >= 0.7 && < 0.8, + aeson >= 0.7 && < 0.11, + uuid == 1.3.*, + vector >= 0.10 && < 0.12, + time >= 1.4 && < 1.6, + hashtables >= 1.1 && < 1.3, + scientific >= 0.2 && < 0.4, + text >= 1 && < 1.3, + bytestring >= 0.10 && < 0.11, + hashable >= 1.2 && < 1.3, + -- control: + data-default-class >= 0.0.1 && < 0.1, + profunctors >= 5.1 && < 6, + contravariant-extras == 0.3.*, + contravariant >= 1.3 && < 2, + either >= 4.4.1 && < 5, transformers >= 0.3 && < 0.5, - base-prelude >= 0.1.3 && < 0.2, - base >= 4.6 && < 4.9 - - -test-suite hspec - type: - exitcode-stdio-1.0 - hs-source-dirs: - hspec - 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, - hasql-backend, - -- - hspec == 2.1.*, - -- - vector, - -- - mtl-prelude < 3, - base-prelude + -- errors: + loch-th == 0.2.*, + placeholders == 0.1.*, + -- general: + base-prelude >= 0.1.19 && < 0.2, + base >= 4.6 && < 5 -test-suite hspec-postgres +-- Note that this test-suite is supposed to be single-threaded. +-- Hence the absense of the appropriate GHC flags. +test-suite tasty type: exitcode-stdio-1.0 hs-source-dirs: - hspec-postgres + tasty main-is: Main.hs - ghc-options: - -threaded - "-with-rtsopts=-N" - -funbox-strict-fields + other-modules: + Main.DSL + Main.Queries + Main.Prelude 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 + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, 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: - -- + -- database: hasql, - hasql-postgres == 0.10.*, - -- - slave-thread == 0.1.*, - -- - hspec == 2.1.*, - -- + -- testing: + tasty == 0.11.*, + tasty-quickcheck == 0.8.*, + tasty-smallcheck == 0.8.*, + tasty-hunit == 0.9.*, + quickcheck-instances >= 0.3.11 && < 0.4, + QuickCheck >= 2.8.1 && < 2.9, + -- data: + uuid, + time, + scientific, + bytestring, text, - -- - monad-control, + vector, + hashable, + dlist, + -- general: + data-default-class, + profunctors, + contravariant, + contravariant-extras, either, - mtl-prelude < 3, - base-prelude + transformers, + base-prelude, + base --- Well, it's not a benchmark actually, --- but in Cabal there's no better way to specify an executable, --- which is not intended for distribution. -benchmark demo +benchmark benchmark type: exitcode-stdio-1.0 hs-source-dirs: - demo + benchmark main-is: Main.hs + other-modules: + Main.Queries + Main.Prelude ghc-options: -O2 -threaded "-with-rtsopts=-N" - -funbox-strict-fields + ghc-prof-options: + -O2 + -threaded + -fprof-auto + "-with-rtsopts=-N -p -s -h -i0.1" + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, 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, - hasql-postgres == 0.10.*, - transformers >= 0.3 && < 0.5, + -- benchmarking: + criterion == 1.1.*, + -- data: + uuid, + time, + scientific, + bytestring, + text, + vector, + hashable, + dlist, + -- general: + deepseq >= 1 && < 2, + data-default-class, + profunctors, + contravariant, + contravariant-extras, + either, + transformers, + base-prelude, base - diff --git a/hspec-postgres/Main.hs b/hspec-postgres/Main.hs deleted file mode 100644 --- a/hspec-postgres/Main.hs +++ /dev/null @@ -1,149 +0,0 @@ -import BasePrelude -import MTLPrelude -import Control.Monad.Trans.Either -import Control.Monad.Trans.Control -import Test.Hspec -import Data.Text (Text) -import qualified Hasql as H -import qualified Hasql.Postgres as HP -import qualified SlaveThread - - -main = - hspec $ do - - context "Multivalue clauses" $ do - -- See http://www.postgresql.org/docs/current/interactive/functions-comparisons.html - - it "contains" $ do - flip shouldBe (Right True) =<< do - session $ - fmap runIdentity $ H.tx Nothing $ H.singleEx $ [H.stmt|SELECT 2 = ANY (?)|] [1,2,3 :: Int] - - it "contains not" $ do - flip shouldBe (Right False) =<< do - session $ - fmap runIdentity $ H.tx Nothing $ H.singleEx $ [H.stmt|SELECT 2 != ALL (?)|] [1,2,3 :: Int] - - context "Tx" $ do - - it "does not commit if in uncommitting mode" $ do - flip shouldBe (Right (Nothing :: Maybe (Identity Int))) =<< do - session $ do - H.tx Nothing $ do - H.unitEx $ [H.stmt|DROP TABLE IF EXISTS a|] - H.unitEx $ [H.stmt|CREATE TABLE a (x INT8 NOT NULL, PRIMARY KEY (x))|] - H.tx (Just (H.Serializable, Just False)) $ do - H.unitEx $ [H.stmt|INSERT INTO a (x) VALUES (2)|] - H.tx Nothing $ do - H.maybeEx $ [H.stmt|SELECT x FROM a WHERE x = 2|] - - context "UTF-8 templates" $ do - - it "encode properly" $ do - flip shouldBe (Right (Just (Identity ("Ёжик" :: Text)))) =<< do - session $ H.tx Nothing $ H.maybeEx $ [H.stmt| SELECT 'Ёжик' |] - - context "Bug" $ do - - context "Unhandled transaction conflict" $ do - - it "should not be" $ do - session $ H.tx Nothing $ do - H.unitEx [H.stmt|DROP TABLE IF EXISTS artist|] - H.unitEx [H.stmt|DROP TABLE IF EXISTS artist_union|] - H.unitEx $ - [H.stmt| - CREATE TABLE "artist_union" ( - "id" BIGSERIAL, - PRIMARY KEY ("id") - ) - |] - H.unitEx $ - [H.stmt| - CREATE TABLE "artist" ( - "id" BIGSERIAL, - "artist_union_id" INT8 NOT NULL, - "names" TEXT[] NOT NULL, - PRIMARY KEY ("id"), - FOREIGN KEY ("artist_union_id") REFERENCES "artist_union" ("id") ON DELETE CASCADE - ) - |] - (signal, block) <- newBatchGate 6 - let - insertArtistUnion :: H.Tx HP.Postgres s Int64 - insertArtistUnion = - fmap (runIdentity . fromJust) $ H.maybeEx $ - [H.stmt| - INSERT INTO artist_union DEFAULT VALUES RETURNING id - |] - insertArtist :: Int64 -> [Text] -> H.Tx HP.Postgres s Int64 - insertArtist unionID artistNames = - fmap (runIdentity . fromJust) $ H.maybeEx $ - [H.stmt| - INSERT INTO artist - (artist_union_id, - names) - VALUES (?, ?) - RETURNING id - |] - unionID - artistNames - process = - SlaveThread.fork $ do - session $ replicateM_ 100 $ do - H.tx (Just (H.Serializable, Just True)) $ do - unionID <- insertArtistUnion - insertArtist unionID ["a", "b", "c"] - signal - replicateM_ 6 process - block - - context "CxRow" $ do - - it "should fail on incorrect arity" $ do - flip shouldSatisfy (\case Left (H.ResultError _) -> True; _ -> False) =<< do - session $ do - H.tx Nothing $ do - H.unitEx [H.stmt|DROP TABLE IF EXISTS data|] - H.unitEx [H.stmt|CREATE TABLE data ( - field1 DECIMAL NOT NULL, - field2 BIGINT NOT NULL, - PRIMARY KEY (field1) - )|] - H.unitEx [H.stmt|INSERT INTO data (field1, field2) VALUES (0, 0)|] - mrow :: Maybe (Double, Int64, String) <- - H.tx Nothing $ - H.maybeEx $ [H.stmt|SELECT * FROM data|] - return () - - --- * Helpers -------------------------- - -newBatchGate :: Int -> IO (IO (), IO ()) -newBatchGate amount = - do - counter <- atomically $ newTVar amount - return $ - let signal = atomically $ readTVar counter >>= writeTVar counter . pred - block = atomically $ readTVar counter >>= \x -> when (x > 0) retry - in (signal, block) - - --- * Hasql utils -------------------------- - -type Session m = - H.Session HP.Postgres m - -session :: MonadBaseControl IO m => Session m r -> m (Either (H.SessionError HP.Postgres) r) -session m = - control $ \unlift -> do - p <- H.acquirePool backendSettings poolSettings - r <- unlift $ H.session p m - H.releasePool p - return r - where - backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres" - poolSettings = fromJust $ H.poolSettings 6 30 diff --git a/hspec/Main.hs b/hspec/Main.hs deleted file mode 100644 --- a/hspec/Main.hs +++ /dev/null @@ -1,51 +0,0 @@ -import BasePrelude -import Test.Hspec -import qualified Hasql as H -import qualified Hasql.Backend as HB -import qualified Data.Vector as V - - -data X - -data instance HB.StmtParam X = - StmtParam String - deriving (Eq, Show) - -deriving instance Show (HB.Stmt X) -deriving instance Eq (HB.Stmt X) - -instance HB.CxValue X Char where - encodeValue = StmtParam . show - -main = - hspec $ do - context "Quasi quoter" $ do - it "supports free variables" $ do - let a = 'a' - b = 'b' - in - (flip shouldBe) - (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue a, HB.encodeValue b]) True) - ([H.stmt| SELECT ($a + $b) |] :: HB.Stmt X) - it "supports ordered placeholders" $ do - (flip shouldBe) - (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue 'a', HB.encodeValue 'b']) True) - ([H.stmt| SELECT (? + ?) |] 'a' 'b' :: HB.Stmt X) - it "does not drop quotes" $ do - let - HB.Stmt t _ _ = - [H.stmt| SELECT "a", 'b' |] - (flip shouldBe) - "SELECT \"a\", 'b'" - t - it "cleans whitespace" $ do - let - HB.Stmt t _ _ = - [H.stmt| CREATE TABLE data ( - field1 DECIMAL NOT NULL, - field2 BIGINT NOT NULL, - PRIMARY KEY (field1) - ) |] - (flip shouldBe) - "CREATE TABLE data ( field1 DECIMAL NOT NULL, field2 BIGINT NOT NULL, PRIMARY KEY (field1) )" - t diff --git a/library/Hasql.hs b/library/Hasql.hs deleted file mode 100644 --- a/library/Hasql.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# LANGUAGE UndecidableInstances, CPP #-} --- | --- This is the API of the \"hasql\" library. --- For an introduction to the package --- and links to more documentation please refer to --- <../ the package's index page>. --- --- This API is completely disinfected from exceptions. --- All error-reporting is explicit and --- is presented using the 'Either' type. -module Hasql -( - -- * Pool - Pool, - acquirePool, - releasePool, - - -- ** Pool Settings - PoolSettings, - poolSettings, - - -- * Session - Session, - session, - - -- ** Session Error - SessionError(..), - - -- * Statement - Bknd.Stmt, - QQ.stmt, - - -- * Statement Execution - Ex, - unitEx, - countEx, - singleEx, - maybeEx, - listEx, - vectorEx, - streamEx, - - -- * Transaction - Tx, - tx, - - -- ** Transaction Settings - Bknd.TxMode(..), - Bknd.TxIsolationLevel(..), - Bknd.TxWriteMode(..), - - -- ** Result Stream - TxStream, - TxStreamListT, - - -- * Row Parser - CxRow.CxRow, -) -where - -import Hasql.Prelude -import qualified Hasql.Backend as Bknd -import qualified Hasql.CxRow as CxRow -import qualified Hasql.QQ as QQ -import qualified ListT -import qualified Data.Pool as Pool -import qualified Data.Vector as Vector -import qualified Data.Vector.Mutable as MVector -import qualified Language.Haskell.TH.Syntax as TH - - --- * Resources -------------------------- - --- | --- A connection pool. -newtype Pool c = - Pool (Pool.Pool (Either (Bknd.CxError c) c)) - --- | --- Given backend-specific connection settings and pool settings, --- acquire a backend connection pool, --- which can then be used to work with the DB. --- --- When combining Hasql with other libraries, --- which throw exceptions it makes sence to utilize --- @Control.Exception.'bracket'@ --- like this: --- --- >bracket (acquirePool bkndStngs poolStngs) (releasePool) $ \pool -> do --- > session pool $ do --- > ... --- > ... any other IO code -acquirePool :: Bknd.Cx c => Bknd.CxSettings c -> PoolSettings -> IO (Pool c) -acquirePool cxSettings (PoolSettings size timeout) = - fmap Pool $ - Pool.createPool (Bknd.acquireCx cxSettings) - (either (const $ return ()) Bknd.releaseCx) - (1) - (fromIntegral timeout) - (size) - --- | --- Release all connections acquired by the pool. -releasePool :: Pool c -> IO () -releasePool (Pool p) = - Pool.destroyAllResources p - - --- ** Pool Settings -------------------------- - --- | --- Settings of a pool. -data PoolSettings = - PoolSettings !Int !Int - deriving (Show) - -instance TH.Lift PoolSettings where - lift (PoolSettings a b) = - [|PoolSettings a b|] - - --- | --- A smart constructor for pool settings. -poolSettings :: - Int - -- ^ - -- The maximum number of connections to keep open. - -- The smallest acceptable value is 1. - -- Requests for connections will block if this limit is reached. - -> - Int - -- ^ - -- The amount of seconds for which an unused connection is kept open. - -- The smallest acceptable value is 1. - -> - Maybe PoolSettings - -- ^ - -- Maybe pool settings, if they are correct. -poolSettings size timeout = - if size > 0 && timeout >= 1 - then Just $ PoolSettings size timeout - else Nothing - - --- * Session -------------------------- - --- | --- A convenience wrapper around 'ReaderT', --- which provides a shared context for execution and error-handling of transactions. -newtype Session c m r = - Session (ReaderT (Pool c) (EitherT (SessionError c) m) r) - deriving (Functor, Applicative, Monad, MonadIO, MonadError (SessionError c)) - -instance MonadTrans (Session c) where - lift = Session . lift . lift - -deriving instance MonadBase IO m => MonadBase IO (Session c m) - -instance MFunctor (Session c) where - hoist f (Session m) = - Session $ ReaderT $ \e -> - EitherT $ f $ runEitherT $ flip runReaderT e $ m - - -#if MIN_VERSION_monad_control(1,0,0) - -instance MonadTransControl (Session c) where - type StT (Session c) a = Either (SessionError c) a - liftWith onUnlift = - Session $ ReaderT $ \e -> - lift $ onUnlift $ \(Session m) -> - runEitherT $ flip runReaderT e $ m - restoreT = - Session . ReaderT . const . EitherT - -instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where - type StM (Session c m) a = ComposeSt (Session c) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -#else - -instance MonadTransControl (Session c) where - newtype StT (Session c) a = - SessionStT (Either (SessionError c) a) - liftWith onUnlift = - Session $ ReaderT $ \e -> - lift $ onUnlift $ \(Session m) -> - liftM SessionStT $ runEitherT $ flip runReaderT e $ m - restoreT = - Session . ReaderT . const . EitherT . liftM (\(SessionStT a) -> a) - -instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where - newtype StM (Session c m) a = - SessionStM (ComposeSt (Session c) m a) - liftBaseWith = - defaultLiftBaseWith SessionStM - restoreM = - defaultRestoreM $ \(SessionStM a) -> a - -#endif - --- | --- Execute a session using an established connection pool. --- --- This is merely a wrapper around 'runReaderT', --- so you can run it around every transaction, --- if you want. -session :: Pool c -> Session c m a -> m (Either (SessionError c) a) -session pool m = - runEitherT $ flip runReaderT pool $ case m of Session m -> m - - --- * Transaction -------------------------- - --- | --- A transaction specialized for a backend connection @c@, --- associated with its intermediate results using an anonymous type-argument @s@ (same trick as in 'ST') --- and producing a result @r@. --- --- Running `IO` in `Tx` is prohibited. --- The motivation is identical to `STM`: --- the `Tx` block may get executed multiple times if any transaction conflicts arise. --- This will result in your effectful `IO` code being executed --- an unpredictable amount of times as well, --- which, chances are, is not what you want. -newtype Tx c s r = - Tx { unwrapTx :: EitherT (SessionError c) (Bknd.Tx c) r } - deriving (Functor, Applicative, Monad) - - -data SessionError c = - -- | - -- A backend-specific connection acquisition error. - -- E.g., a failure to establish a connection. - CxError (Bknd.CxError c) | - -- | - -- A backend-specific transaction error. - -- It should cover all possible failures related to an established connection, - -- including the loss of connection, query errors and database failures. - TxError (Bknd.TxError c) | - -- | - -- Attempt to parse a result into an incompatible type. - -- Indicates either a mismatching schema or an incorrect query. - ResultError Text - -deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (SessionError c) -deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (SessionError c) - --- | --- Execute a transaction in a session. --- --- This function ensures on the type level, --- that it's impossible to return @'TxStreamListT' s m r@ from it. -tx :: (Bknd.CxTx c, MonadBaseControl IO m) => Bknd.TxMode -> (forall s. Tx c s r) -> Session c m r -tx mode (Tx m) = - Session $ ReaderT $ \(Pool pool) -> - Pool.withResource pool $ \e -> do - c <- hoistEither $ mapLeft CxError e - let - attempt = - do - r <- EitherT $ liftBase $ fmap (either (Left . TxError) Right) $ - Bknd.runTx c mode $ runEitherT m - maybe attempt hoistEither r - in attempt - - --- * Statements execution -------------------------- - --- | --- Statement executor. --- --- Just an alias to a function, which executes a statement in 'Tx'. -type Ex c s r = - Bknd.Stmt c -> Tx c s r - --- | --- Execute a statement without processing the result. -unitEx :: Ex c s () -unitEx = - Tx . lift . Bknd.unitTx - --- | --- Execute a statement and count the amount of affected rows. --- Useful for resolving how many rows were updated or deleted. -countEx :: Bknd.CxValue c Word64 => Ex c s Word64 -countEx = - Tx . lift . Bknd.countTx - --- | --- Execute a statement, --- which produces exactly one result row. --- E.g., @INSERT@, which returns an autoincremented identifier, --- or @SELECT COUNT@, or @SELECT EXISTS@. --- --- Please note that using this executor for selecting rows is conceptually wrong, --- since in that case the results are always optional. --- Use 'maybeEx', 'listEx' or 'vectorEx' instead. --- --- If the result is empty this executor will raise 'ResultError'. -singleEx :: CxRow.CxRow c r => Ex c s r -singleEx = - join . fmap (maybe (Tx $ left $ ResultError "No rows on 'singleEx'") return) . - maybeEx - --- | --- Execute a statement, --- which optionally produces a single result row. -maybeEx :: CxRow.CxRow c r => Ex c s (Maybe r) -maybeEx = - fmap (fmap Vector.unsafeHead . mfilter (not . Vector.null) . Just) . vectorEx - --- | --- Execute a statement, --- and produce a list of results. -listEx :: CxRow.CxRow c r => Ex c s [r] -listEx = - fmap toList . vectorEx - --- | --- Execute a statement, --- and produce a vector of results. -vectorEx :: CxRow.CxRow c r => Ex c s (Vector r) -vectorEx s = - Tx $ do - r <- lift $ Bknd.vectorTx s - EitherT $ return $ traverse ((mapLeft ResultError) . CxRow.parseRow) $ r - --- | --- Given a batch size, execute a statement with a cursor, --- and produce a result stream. --- --- The cursor allows you to fetch virtually limitless results in a constant memory --- at a cost of a small overhead. --- --- The batch size parameter controls how many rows will be fetched --- during every roundtrip to the database. --- A minimum value of 256 seems to be sane. --- --- Note that in most databases cursors require establishing a database transaction, --- so depending on a backend the transaction may result in an error, --- if you run it improperly. -streamEx :: CxRow.CxRow c r => Int -> Ex c s (TxStream c s r) -streamEx n s = - Tx $ do - r <- lift $ Bknd.streamTx n s - return $ TxStreamListT $ do - row <- hoist (Tx . lift) r - lift $ Tx $ EitherT $ return $ mapLeft ResultError $ CxRow.parseRow $ row - - --- * Result Stream -------------------------- - --- | --- A stream of results, --- which fetches approximately only those that you reach. -type TxStream c s = - TxStreamListT s (Tx c s) - --- | --- A wrapper around 'ListT.ListT', --- which uses the same trick as the 'ST' monad to associate with the --- context monad and become impossible to be returned from it, --- using the anonymous type parameter @s@. --- This lets the library ensure that it is safe to automatically --- release all the connections associated with this stream. --- --- All the functions of the \"list-t\" library are applicable to this type, --- amongst which are 'ListT.head', 'ListT.toList', 'ListT.fold', 'ListT.traverse_'. -newtype TxStreamListT s m r = - TxStreamListT (ListT.ListT m r) - deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus, - Monoid, ListT.MonadCons) - -instance ListT.MonadTransUncons (TxStreamListT s) where - uncons = - (liftM . fmap . fmap) (unsafeCoerce :: ListT.ListT m r -> TxStreamListT s m r) . - ListT.uncons . - (unsafeCoerce :: TxStreamListT s m r -> ListT.ListT m r) - diff --git a/library/Hasql/Commands.hs b/library/Hasql/Commands.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Commands.hs @@ -0,0 +1,33 @@ +module Hasql.Commands +( + Commands, + asBytes, + setEncodingToUTF8, + setMinClientMessagesToWarning, +) +where + +import Hasql.Prelude +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Builder as BB +import qualified Data.ByteString.Lazy.Builder.ASCII as BB +import qualified Data.ByteString.Lazy as BL + + +newtype Commands = + Commands (DList BB.Builder) + deriving (Monoid) + +asBytes :: Commands -> ByteString +asBytes (Commands list) = + BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list + +setEncodingToUTF8 :: Commands +setEncodingToUTF8 = + Commands (pure "SET client_encoding = 'UTF8'") + +setMinClientMessagesToWarning :: Commands +setMinClientMessagesToWarning = + Commands (pure "SET client_min_messages TO WARNING") + + diff --git a/library/Hasql/Connection.hs b/library/Hasql/Connection.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Connection.hs @@ -0,0 +1,12 @@ +-- | +-- This module provides a low-level effectful API dealing with the connections to the database. +module Hasql.Connection +( + Connection, + ConnectionError(..), + acquire, + release, +) +where + +import Hasql.Connection.Impl diff --git a/library/Hasql/Connection/Impl.hs b/library/Hasql/Connection/Impl.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Connection/Impl.hs @@ -0,0 +1,37 @@ +module Hasql.Connection.Impl +where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.IO as IO + + +-- | +-- A single connection to the database. +data Connection = + Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry + +-- | +-- Possible details of the connection acquistion error. +type ConnectionError = + Maybe ByteString + +-- | +-- Acquire a connection using the provided settings encoded according to the PostgreSQL format. +acquire :: ByteString -> IO (Either ConnectionError Connection) +acquire settings = + {-# SCC "acquire" #-} + runEitherT $ do + pqConnection <- lift (IO.acquireConnection settings) + lift (IO.checkConnectionStatus pqConnection) >>= traverse left + lift (IO.initConnection pqConnection) + integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection) + registry <- lift (IO.acquirePreparedStatementRegistry) + pure (Connection pqConnection integerDatetimes registry) + +-- | +-- Release the connection. +release :: Connection -> IO () +release (Connection pqConnection _ _) = + LibPQ.finish pqConnection diff --git a/library/Hasql/CxRow.hs b/library/Hasql/CxRow.hs deleted file mode 100644 --- a/library/Hasql/CxRow.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Hasql.CxRow where - -import Hasql.Prelude -import Language.Haskell.TH -import qualified Hasql.Backend as Bknd -import qualified Data.Vector as Vector -import qualified Hasql.TH as THUtil - - --- | --- This class is only intended to be used with the supplied instances, --- which should be enough to cover all use cases. -class CxRow c r where - parseRow :: Bknd.ResultRow c -> Either Text r - -instance CxRow c () where - parseRow row = - if Vector.null row - then Right () - else Left "Not an empty row" - -instance Bknd.CxValue c v => CxRow c (Identity v) where - parseRow row = do - Identity <$> Bknd.decodeValue (Vector.unsafeHead row) - --- Generate tuple instaces using Template Haskell: -return $ flip map [2 .. 24] $ \arity -> - let - varNames = - [1 .. arity] >>= \i -> return (mkName ('v' : show i)) - varTypes = - map VarT varNames - connectionType = - VarT (mkName "c") - constraints = - map (\t -> THUtil.classP ''Bknd.CxValue [connectionType, t]) varTypes - head = - AppT (AppT (ConT ''CxRow) connectionType) (foldl AppT (TupleT arity) varTypes) - parseRowDec = - FunD 'parseRow [Clause [VarP rowVarName] (NormalB e) []] - where - rowVarName = mkName "row" - e = - THUtil.purify $ - [| - let actualLength = Vector.length $(varE rowVarName) - expectedLength = $(litE (IntegerL $ fromIntegral arity)) - in if actualLength == expectedLength - then $(pure $ THUtil.applicativeE (ConE (tupleDataName arity)) lookups) - else Left $ fromString $ ($ "") $ - showString "Inappropriate row length: " . shows actualLength . - showString ", expecting: " . shows expectedLength . - showString " instead" - |] - where - lookups = do - i <- [0 .. pred arity] - return $ THUtil.purify $ - [| - Bknd.decodeValue - (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) ) - |] - in InstanceD constraints head [parseRowDec] - diff --git a/library/Hasql/Decoding.hs b/library/Hasql/Decoding.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding.hs @@ -0,0 +1,669 @@ +-- | +-- A DSL for declaration of result decoders. +module Hasql.Decoding +( + -- * Result + Result, + unit, + rowsAffected, + singleRow, + -- ** Specialized multi-row results + maybeRow, + rowsVector, + rowsList, + -- ** Multi-row traversers + foldlRows, + foldrRows, + -- * Row + Row, + value, + nullableValue, + -- * Value + Value, + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + text, + bytea, + date, + timestamp, + timestamptz, + time, + timetz, + interval, + uuid, + json, + array, + composite, + hstore, + enum, + -- * Array + Array, + arrayDimension, + arrayValue, + arrayNullableValue, + -- * Composite + Composite, + compositeValue, + compositeNullableValue, +) +where + +import Hasql.Prelude hiding (maybe, bool) +import qualified Data.Aeson as Aeson +import qualified Data.Vector as Vector +import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified Hasql.Decoding.Results as Results +import qualified Hasql.Decoding.Result as Result +import qualified Hasql.Decoding.Row as Row +import qualified Hasql.Decoding.Value as Value +import qualified Hasql.Decoding.Array as Array +import qualified Hasql.Decoding.Composite as Composite +import qualified Hasql.Prelude as Prelude + + +-- * Result +------------------------- + +-- | +-- Decoder of a query result. +-- +newtype Result a = + Result (Results.Results a) + deriving (Functor) + +-- | +-- Decode no value from the result. +-- +-- Useful for statements like @INSERT@ or @CREATE@. +-- +{-# INLINABLE unit #-} +unit :: Result () +unit = + Result (Results.single Result.unit) + +-- | +-- Get the amount of rows affected by such statements as +-- @UPDATE@ or @DELETE@. +-- +{-# INLINABLE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + Result (Results.single Result.rowsAffected) + +-- | +-- Exactly one row. +-- Will raise the 'Hasql.Query.UnexpectedAmountOfRows' error if it's any other. +-- +{-# INLINABLE singleRow #-} +singleRow :: Row a -> Result a +singleRow (Row row) = + Result (Results.single (Result.single row)) + +-- ** Multi-row traversers +------------------------- + +-- | +-- Foldl multiple rows. +-- +{-# INLINABLE foldlRows #-} +foldlRows :: (a -> b -> a) -> a -> Row b -> Result a +foldlRows step init (Row row) = + Result (Results.single (Result.foldl step init row)) + +-- | +-- Foldr multiple rows. +-- +{-# INLINABLE foldrRows #-} +foldrRows :: (b -> a -> a) -> a -> Row b -> Result a +foldrRows step init (Row row) = + Result (Results.single (Result.foldr step init row)) + +-- ** Specialized multi-row results +------------------------- + +-- | +-- Maybe one row or none. +-- +{-# INLINABLE maybeRow #-} +maybeRow :: Row a -> Result (Maybe a) +maybeRow (Row row) = + Result (Results.single (Result.maybe row)) + +-- | +-- Zero or more rows packed into the vector. +-- +-- It's recommended to prefer this function to 'rowsList', +-- since it performs notably better. +-- +{-# INLINABLE rowsVector #-} +rowsVector :: Row a -> Result (Vector a) +rowsVector (Row row) = + Result (Results.single (Result.vector row)) + +-- | +-- Zero or more rows packed into the list. +-- +{-# INLINABLE rowsList #-} +rowsList :: Row a -> Result [a] +rowsList = + foldrRows strictCons [] + + +-- ** Instances +------------------------- + +-- | Maps to 'unit'. +instance Default (Result ()) where + {-# INLINE def #-} + def = + unit + +-- | Maps to 'rowsAffected'. +instance Default (Result Int64) where + {-# INLINE def #-} + def = + rowsAffected + +-- | Maps to @('maybeRow' def)@. +instance Default (Row a) => Default (Result (Maybe a)) where + {-# INLINE def #-} + def = + maybeRow def + +-- | Maps to @('rowsVector' def)@. +instance Default (Row a) => Default (Result (Vector a)) where + {-# INLINE def #-} + def = + rowsVector def + +-- | Maps to @('rowsList' def)@. +instance Default (Row a) => Default (Result ([] a)) where + {-# INLINE def #-} + def = + rowsList def + +-- | Maps to @(fmap Identity ('singleRow' def)@. +instance Default (Row a) => Default (Result (Identity a)) where + {-# INLINE def #-} + def = + fmap Identity (singleRow def) + + +-- * Row +------------------------- + +-- | +-- Decoder of an individual row, +-- which gets composed of column value decoders. +-- +-- E.g.: +-- +-- >x :: Row (Maybe Int64, Text, TimeOfDay) +-- >x = +-- > (,,) <$> nullableValue int8 <*> value text <*> value time +-- +newtype Row a = + Row (Row.Row a) + deriving (Functor, Applicative, Monad) + +-- | +-- Lift an individual non-nullable value decoder to a composable row decoder. +-- +{-# INLINABLE value #-} +value :: Value a -> Row a +value (Value imp) = + Row (Row.nonNullValue imp) + +-- | +-- Lift an individual nullable value decoder to a composable row decoder. +-- +{-# INLINABLE nullableValue #-} +nullableValue :: Value a -> Row (Maybe a) +nullableValue (Value imp) = + Row (Row.value imp) + + +-- ** Instances +------------------------- + +instance Default (Value a) => Default (Row (Identity a)) where + {-# INLINE def #-} + def = + fmap Identity (value def) + +instance Default (Value a) => Default (Row (Maybe a)) where + {-# INLINE def #-} + def = + nullableValue def + +instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where + {-# INLINE def #-} + def = + ap (fmap (,) (value def)) (value def) + + +-- * Value +------------------------- + +-- | +-- Decoder of an individual value. +-- +newtype Value a = + Value (Value.Value a) + deriving (Functor) + + +-- ** Plain value decoders +------------------------- + +-- | +-- Decoder of the @BOOL@ values. +-- +{-# INLINABLE bool #-} +bool :: Value Bool +bool = + Value (Value.decoder (const Decoder.bool)) + +-- | +-- Decoder of the @INT2@ values. +-- +{-# INLINABLE int2 #-} +int2 :: Value Int16 +int2 = + Value (Value.decoder (const Decoder.int)) + +-- | +-- Decoder of the @INT4@ values. +-- +{-# INLINABLE int4 #-} +int4 :: Value Int32 +int4 = + Value (Value.decoder (const Decoder.int)) + +-- | +-- Decoder of the @INT8@ values. +-- +{-# INLINABLE int8 #-} +int8 :: Value Int64 +int8 = + {-# SCC "int8" #-} + Value (Value.decoder (const ({-# SCC "int8.int" #-} Decoder.int))) + +-- | +-- Decoder of the @FLOAT4@ values. +-- +{-# INLINABLE float4 #-} +float4 :: Value Float +float4 = + Value (Value.decoder (const Decoder.float4)) + +-- | +-- Decoder of the @FLOAT8@ values. +-- +{-# INLINABLE float8 #-} +float8 :: Value Double +float8 = + Value (Value.decoder (const Decoder.float8)) + +-- | +-- Decoder of the @NUMERIC@ values. +-- +{-# INLINABLE numeric #-} +numeric :: Value Scientific +numeric = + Value (Value.decoder (const Decoder.numeric)) + +-- | +-- Decoder of the @CHAR@ values. +-- Note that it supports UTF-8 values. +{-# INLINABLE char #-} +char :: Value Char +char = + Value (Value.decoder (const Decoder.char)) + +-- | +-- Decoder of the @TEXT@ values. +-- +{-# INLINABLE text #-} +text :: Value Text +text = + Value (Value.decoder (const Decoder.text_strict)) + +-- | +-- Decoder of the @BYTEA@ values. +-- +{-# INLINABLE bytea #-} +bytea :: Value ByteString +bytea = + Value (Value.decoder (const Decoder.bytea_strict)) + +-- | +-- Decoder of the @DATE@ values. +-- +{-# INLINABLE date #-} +date :: Value Day +date = + Value (Value.decoder (const Decoder.date)) + +-- | +-- Decoder of the @TIMESTAMP@ values. +-- +{-# INLINABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = + Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int)) + +-- | +-- Decoder of the @TIMESTAMPTZ@ values. +-- +-- /NOTICE/ +-- +-- Postgres does not store the timezone information of @TIMESTAMPTZ@. +-- Instead it stores a UTC value and performs silent conversions +-- to the currently set timezone, when dealt with in the text format. +-- However this library bypasses the silent conversions +-- and communicates with Postgres using the UTC values directly. +{-# INLINABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = + Value (Value.decoder (Prelude.bool Decoder.timestamptz_float Decoder.timestamptz_int)) + +-- | +-- Decoder of the @TIME@ values. +-- +{-# INLINABLE time #-} +time :: Value TimeOfDay +time = + Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int)) + +-- | +-- Decoder of the @TIMETZ@ values. +-- +-- Unlike in case of @TIMESTAMPTZ@, +-- Postgres does store the timezone information for @TIMETZ@. +-- However the Haskell's \"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. +{-# INLINABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = + Value (Value.decoder (Prelude.bool Decoder.timetz_float Decoder.timetz_int)) + +-- | +-- Decoder of the @INTERVAL@ values. +-- +{-# INLINABLE interval #-} +interval :: Value DiffTime +interval = + Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int)) + +-- | +-- Decoder of the @UUID@ values. +-- +{-# INLINABLE uuid #-} +uuid :: Value UUID +uuid = + Value (Value.decoder (const Decoder.uuid)) + +-- | +-- Decoder of the @JSON@ values. +-- +{-# INLINABLE json #-} +json :: Value Aeson.Value +json = + Value (Value.decoder (const Decoder.json)) + + +-- ** Composite value decoders +------------------------- + +-- | +-- Lifts the 'Array' decoder to the 'Value' decoder. +-- +{-# INLINABLE array #-} +array :: Array a -> Value a +array (Array imp) = + Value (Value.decoder (Array.run imp)) + +-- | +-- Lifts the 'Composite' decoder to the 'Value' decoder. +-- +{-# INLINABLE composite #-} +composite :: Composite a -> Value a +composite (Composite imp) = + Value (Value.decoder (Composite.run imp)) + +-- | +-- A generic decoder of @HSTORE@ values. +-- +-- Here's how you can use it to construct a specific value: +-- +-- @ +-- x :: Value [(Text, Maybe Text)] +-- x = +-- hstore 'replicateM' +-- @ +-- +{-# INLINABLE hstore #-} +hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a +hstore replicateM = + Value (Value.decoder (const (Decoder.hstore replicateM Decoder.text_strict Decoder.text_strict))) + +-- | +-- Given a partial mapping from text to value, +-- produces a decoder of that value. +enum :: (Text -> Maybe a) -> Value a +enum mapping = + Value (Value.decoder (const (Decoder.enum mapping))) + + +-- ** Instances +------------------------- + +-- | +-- Maps to 'bool'. +instance Default (Value Bool) where + {-# INLINE def #-} + def = + bool + +-- | +-- Maps to 'int2'. +instance Default (Value Int16) where + {-# INLINE def #-} + def = + int2 + +-- | +-- Maps to 'int4'. +instance Default (Value Int32) where + {-# INLINE def #-} + def = + int4 + +-- | +-- Maps to 'int8'. +instance Default (Value Int64) where + {-# INLINE def #-} + def = + int8 + +-- | +-- Maps to 'float4'. +instance Default (Value Float) where + {-# INLINE def #-} + def = + float4 + +-- | +-- Maps to 'float8'. +instance Default (Value Double) where + {-# INLINE def #-} + def = + float8 + +-- | +-- Maps to 'numeric'. +instance Default (Value Scientific) where + {-# INLINE def #-} + def = + numeric + +-- | +-- Maps to 'char'. +instance Default (Value Char) where + {-# INLINE def #-} + def = + char + +-- | +-- Maps to 'text'. +instance Default (Value Text) where + {-# INLINE def #-} + def = + text + +-- | +-- Maps to 'bytea'. +instance Default (Value ByteString) where + {-# INLINE def #-} + def = + bytea + +-- | +-- Maps to 'date'. +instance Default (Value Day) where + {-# INLINE def #-} + def = + date + +-- | +-- Maps to 'timestamp'. +instance Default (Value LocalTime) where + {-# INLINE def #-} + def = + timestamp + +-- | +-- Maps to 'timestamptz'. +instance Default (Value UTCTime) where + {-# INLINE def #-} + def = + timestamptz + +-- | +-- Maps to 'time'. +instance Default (Value TimeOfDay) where + {-# INLINE def #-} + def = + time + +-- | +-- Maps to 'timetz'. +instance Default (Value (TimeOfDay, TimeZone)) where + {-# INLINE def #-} + def = + timetz + +-- | +-- Maps to 'interval'. +instance Default (Value DiffTime) where + {-# INLINE def #-} + def = + interval + +-- | +-- Maps to 'uuid'. +instance Default (Value UUID) where + {-# INLINE def #-} + def = + uuid + +-- | +-- Maps to 'json'. +instance Default (Value Aeson.Value) where + {-# INLINE def #-} + def = + json + + +-- * Array decoders +------------------------- + +-- | +-- A generic array decoder. +-- +-- Here's how you can use it to produce a specific array value decoder: +-- +-- @ +-- x :: Value [[Text]] +-- x = +-- array (arrayDimension 'replicateM' (arrayDimension 'replicateM' (arrayValue text))) +-- @ +-- +newtype Array a = + Array (Array.Array a) + deriving (Functor) + +-- | +-- A function for parsing a dimension of an array. +-- Provides support for multi-dimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines the output value. +-- +-- * A decoder of its components, which can be either another 'arrayDimension', +-- 'arrayValue' or 'arrayNullableValue'. +-- +{-# INLINABLE arrayDimension #-} +arrayDimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b +arrayDimension replicateM (Array imp) = + Array (Array.dimension replicateM imp) + +-- | +-- Lift a 'Value' decoder into an 'Array' decoder for parsing of non-nullable leaf values. +{-# INLINABLE arrayValue #-} +arrayValue :: Value a -> Array a +arrayValue (Value imp) = + Array (Array.nonNullValue (Value.run imp)) + +-- | +-- Lift a 'Value' decoder into an 'Array' decoder for parsing of nullable leaf values. +{-# INLINABLE arrayNullableValue #-} +arrayNullableValue :: Value a -> Array (Maybe a) +arrayNullableValue (Value imp) = + Array (Array.value (Value.run imp)) + + +-- * Composite decoders +------------------------- + +-- | +-- Composable decoder of composite values (rows, records). +newtype Composite a = + Composite (Composite.Composite a) + deriving (Functor, Applicative, Monad) + +-- | +-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values. +{-# INLINABLE compositeValue #-} +compositeValue :: Value a -> Composite a +compositeValue (Value imp) = + Composite (Composite.nonNullValue (Value.run imp)) + +-- | +-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of nullable leaf values. +{-# INLINABLE compositeNullableValue #-} +compositeNullableValue :: Value a -> Composite (Maybe a) +compositeNullableValue (Value imp) = + Composite (Composite.value (Value.run imp)) + diff --git a/library/Hasql/Decoding/Array.hs b/library/Hasql/Decoding/Array.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding/Array.hs @@ -0,0 +1,31 @@ +module Hasql.Decoding.Array where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder + + +newtype Array a = + Array (ReaderT Bool Decoder.ArrayDecoder a) + deriving (Functor) + +{-# INLINE run #-} +run :: Array a -> Bool -> Decoder.Decoder a +run (Array imp) env = + Decoder.array (runReaderT imp env) + +{-# INLINE dimension #-} +dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b +dimension replicateM (Array imp) = + Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env) + +{-# INLINE value #-} +value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a) +value decoder' = + Array $ ReaderT $ Decoder.arrayValue . decoder' + +{-# INLINE nonNullValue #-} +nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a +nonNullValue decoder' = + Array $ ReaderT $ Decoder.arrayNonNullValue . decoder' + diff --git a/library/Hasql/Decoding/Composite.hs b/library/Hasql/Decoding/Composite.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding/Composite.hs @@ -0,0 +1,26 @@ +module Hasql.Decoding.Composite where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder + + +newtype Composite a = + Composite (ReaderT Bool Decoder.CompositeDecoder a) + deriving (Functor, Applicative, Monad) + +{-# INLINE run #-} +run :: Composite a -> Bool -> Decoder.Decoder a +run (Composite imp) env = + Decoder.composite (runReaderT imp env) + +{-# INLINE value #-} +value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a) +value decoder' = + Composite $ ReaderT $ Decoder.compositeValue . decoder' + +{-# INLINE nonNullValue #-} +nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a +nonNullValue decoder' = + Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder' + diff --git a/library/Hasql/Decoding/Result.hs b/library/Hasql/Decoding/Result.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding/Result.hs @@ -0,0 +1,232 @@ +module Hasql.Decoding.Result where + +import Hasql.Prelude hiding (maybe, many) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Decoding.Row as Row +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.ByteString as ByteString +import qualified Hasql.Prelude as Prelude +import qualified Data.Vector as Vector +import qualified Data.Vector.Mutable as MutableVector + + +newtype Result a = + Result (ReaderT (Bool, LibPQ.Result) (EitherT Error IO) a) + deriving (Functor, Applicative, Monad) + +data Error = + -- | + -- An error reported by the DB. Code, message, details, hint. + -- + -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; + -- it can be used by front-end applications to perform specific operations (such as error handling) + -- in response to a particular database error. + -- For a list of the possible SQLSTATE codes, see Appendix A. + -- This field is not localizable, and is always present. + -- + -- * The primary human-readable error message (typically one line). Always present. + -- + -- * Detail: an optional secondary error message carrying more detail about the problem. + -- Might run to multiple lines. + -- + -- * Hint: an optional suggestion what to do about the problem. + -- This is intended to differ from detail in that it offers advice (potentially inappropriate) + -- rather than hard facts. Might run to multiple lines. + ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | + -- | + -- The database returned an unexpected result. + -- Indicates an improper statement or a schema mismatch. + UnexpectedResult !Text | + -- | + -- An error of the row reader, preceded by the index of the row. + RowError !Int !Row.Error | + -- | + -- An unexpected amount of rows. + UnexpectedAmountOfRows !Int + deriving (Show) + +{-# INLINE run #-} +run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a) +run (Result reader) env = + runEitherT (runReaderT reader env) + +{-# INLINE unit #-} +unit :: Result () +unit = + checkExecStatus $ \case + LibPQ.CommandOk -> True + LibPQ.TuplesOk -> True + _ -> False + +{-# INLINE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + do + checkExecStatus $ \case + LibPQ.CommandOk -> True + _ -> False + Result $ ReaderT $ \(_, result) -> EitherT $ + LibPQ.cmdTuples result & fmap cmdTuplesReader + where + cmdTuplesReader = + notNothing >=> notEmpty >=> decimal + where + notNothing = + Prelude.maybe (Left (UnexpectedResult "No bytes")) Right + notEmpty bytes = + if ByteString.null bytes + then Left (UnexpectedResult "Empty bytes") + else Right bytes + decimal bytes = + mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $ + Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes + +{-# INLINE checkExecStatus #-} +checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () +checkExecStatus predicate = + {-# SCC "checkExecStatus" #-} + do + status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result + unless (predicate status) $ do + case status of + LibPQ.BadResponse -> serverError + LibPQ.NonfatalError -> serverError + LibPQ.FatalError -> serverError + _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) + +{-# INLINE serverError #-} +serverError :: Result () +serverError = + Result $ ReaderT $ \(_, result) -> EitherT $ do + code <- + fmap (fromMaybe ($bug "No code")) $ + LibPQ.resultErrorField result LibPQ.DiagSqlstate + message <- + fmap (fromMaybe ($bug "No message")) $ + LibPQ.resultErrorField result LibPQ.DiagMessagePrimary + detail <- + LibPQ.resultErrorField result LibPQ.DiagMessageDetail + hint <- + LibPQ.resultErrorField result LibPQ.DiagMessageHint + pure $ Left $ ServerError code message detail hint + +{-# INLINE maybe #-} +maybe :: Row.Row a -> Result (Maybe a) +maybe rowDec = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + case maxRows of + 0 -> return (Right Nothing) + 1 -> do + maxCols <- LibPQ.nfields result + fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE single #-} +single :: Row.Row a -> Result a +single rowDec = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + case maxRows of + 1 -> do + maxCols <- LibPQ.nfields result + fmap (mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE vector #-} +vector :: Row.Row a -> Result (Vector a) +vector rowDec = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + mvector <- MutableVector.unsafeNew (rowToInt maxRows) + failureRef <- newIORef Nothing + forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) + Right !x -> MutableVector.unsafeWrite mvector rowIndex x + readIORef failureRef >>= \case + Nothing -> Right <$> Vector.unsafeFreeze mvector + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldl #-} +foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a +foldl step init rowDec = + {-# SCC "foldl" #-} + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ {-# SCC "traversal" #-} do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + accRef <- newIORef init + failureRef <- newIORef Nothing + forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) + Right !x -> modifyIORef accRef (\acc -> step acc x) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldr #-} +foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a +foldr step init rowDec = + {-# SCC "foldr" #-} + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + accRef <- newIORef init + failureRef <- newIORef Nothing + forMToZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) + Right !x -> modifyIORef accRef (\acc -> step x acc) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral diff --git a/library/Hasql/Decoding/Results.hs b/library/Hasql/Decoding/Results.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding/Results.hs @@ -0,0 +1,91 @@ +-- | +-- An API for retrieval of multiple results. +-- Can be used to handle: +-- +-- * A single result, +-- +-- * Individual results of a multi-statement query +-- with the help of "Applicative" and "Monad", +-- +-- * Row-by-row fetching. +-- +module Hasql.Decoding.Results where + +import Hasql.Prelude hiding (maybe, many) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Prelude as Prelude +import qualified Hasql.Decoding.Result as Result +import qualified Hasql.Decoding.Row as Row + + +newtype Results a = + Results (ReaderT (Bool, LibPQ.Connection) (EitherT Error IO) a) + deriving (Functor, Applicative, Monad) + +data Error = + -- | + -- An error on the client-side, + -- with a message generated by the \"libpq\" library. + -- Usually indicates problems with the connection. + ClientError !(Maybe ByteString) | + ResultError !Result.Error + +{-# INLINE run #-} +run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a) +run (Results stack) env = + runEitherT (runReaderT stack env) + +{-# INLINE clientError #-} +clientError :: Results a +clientError = + Results $ ReaderT $ \(_, connection) -> EitherT $ + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Parse a single result. +{-# INLINE single #-} +single :: Result.Result a -> Results a +single resultDec = + Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> + mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) + <* LibPQ.unsafeFreeResult result + Nothing -> + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINE getResult #-} +getResult :: Results LibPQ.Result +getResult = + Results $ ReaderT $ \(_, connection) -> EitherT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> pure (Right result) + Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINE getResultMaybe #-} +getResultMaybe :: Results (Maybe LibPQ.Result) +getResultMaybe = + Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection + +{-# INLINE dropRemainders #-} +dropRemainders :: Results () +dropRemainders = + {-# SCC "dropRemainders" #-} + Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection + where + loop integerDatetimes connection = + getResultMaybe >>= Prelude.maybe (pure ()) onResult + where + getResultMaybe = + lift $ LibPQ.getResult connection + onResult result = + checkErrors *> loop integerDatetimes connection + where + checkErrors = + EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result) diff --git a/library/Hasql/Decoding/Row.hs b/library/Hasql/Decoding/Row.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding/Row.hs @@ -0,0 +1,65 @@ +module Hasql.Decoding.Row where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified Hasql.Decoding.Value as Value + + +newtype Row a = + Row (ReaderT Env (EitherT Error IO) a) + deriving (Functor, Applicative, Monad) + +data Env = + Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column) + +data Error = + EndOfInput | + UnexpectedNull | + ValueError !Text + deriving (Show) + + +-- * Functions +------------------------- + +{-# INLINE run #-} +run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a) +run (Row impl) (result, row, columnsAmount, integerDatetimes) = + do + columnRef <- newIORef 0 + runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef)) + +{-# INLINE error #-} +error :: Error -> Row a +error x = + Row (ReaderT (const (EitherT (pure (Left x))))) + +-- | +-- Next value, decoded using the provided value decoder. +{-# INLINE value #-} +value :: Value.Value a -> Row (Maybe a) +value valueDec = + {-# SCC "value" #-} + Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> EitherT $ do + col <- readIORef columnRef + writeIORef columnRef (succ col) + if col < columnsAmount + then do + valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col + pure $ + case valueMaybe of + Nothing -> + Right Nothing + Just value -> + fmap Just $ mapLeft ValueError $ + {-# SCC "decode" #-} Decoder.run (Value.run valueDec integerDatetimes) value + else pure (Left EndOfInput) + +-- | +-- Next value, decoded using the provided value decoder. +{-# INLINE nonNullValue #-} +nonNullValue :: Value.Value a -> Row a +nonNullValue valueDec = + {-# SCC "nonNullValue" #-} + value valueDec >>= maybe (error UnexpectedNull) pure diff --git a/library/Hasql/Decoding/Value.hs b/library/Hasql/Decoding/Value.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoding/Value.hs @@ -0,0 +1,23 @@ +module Hasql.Decoding.Value where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder + + +newtype Value a = + Value (ReaderT Bool Decoder.Decoder a) + deriving (Functor) + + +{-# INLINE run #-} +run :: Value a -> Bool -> Decoder.Decoder a +run (Value imp) integerDatetimes = + runReaderT imp integerDatetimes + +{-# INLINE decoder #-} +decoder :: (Bool -> Decoder.Decoder a) -> Value a +decoder = + {-# SCC "decoder" #-} + Value . ReaderT + diff --git a/library/Hasql/Encoding.hs b/library/Hasql/Encoding.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoding.hs @@ -0,0 +1,483 @@ +-- | +-- A DSL for declaration of query parameter encoders. +module Hasql.Encoding +( + -- * Params + Params, + unit, + value, + nullableValue, + -- * Value + Value, + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + text, + bytea, + date, + timestamp, + timestamptz, + time, + timetz, + interval, + uuid, + json, + array, + enum, + -- * Array + Array, + arrayValue, + arrayNullableValue, + arrayDimension, +) +where + +import Hasql.Prelude hiding (bool) +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Data.Aeson as Aeson +import qualified Hasql.Encoding.Params as Params +import qualified Hasql.Encoding.Value as Value +import qualified Hasql.Encoding.Array as Array +import qualified Hasql.PTI as PTI +import qualified Hasql.Prelude as Prelude + + +-- * Parameters Product Encoder +------------------------- + +-- | +-- Encoder of some representation of the parameters product. +-- +-- Has instances of 'Contravariant', 'Divisible' and 'Monoid', +-- which you can use to compose multiple parameters together. +-- E.g., +-- +-- @ +-- someParamsEncoder :: 'Params' (Int64, Maybe Text) +-- someParamsEncoder = +-- 'contramap' 'fst' ('value' 'int8') '<>' +-- 'contramap' 'snd' ('nullableValue' 'text') +-- @ +-- +-- As a general solution for tuples of any arity, instead of 'fst' and 'snd', +-- consider the functions of the @contrazip@ family +-- from the \"contravariant-extras\" package. +-- E.g., here's how you can achieve the same as the above: +-- +-- @ +-- someParamsEncoder :: 'Params' (Int64, Maybe Text) +-- someParamsEncoder = +-- 'contrazip2' ('value' 'int8') ('nullableValue' 'text') +-- @ +-- +-- Here's how you can implement encoders for custom composite types: +-- +-- @ +-- data Person = +-- Person { name :: Text, gender :: Gender, age :: Int } +-- +-- data Gender = +-- Male | Female +-- +-- personParams :: 'Params' Person +-- personParams = +-- 'contramap' name ('value' 'text') '<>' +-- 'contramap' gender ('value' genderValue) '<>' +-- 'contramap' (fromIntegral . age) ('value' 'int8') +-- +-- genderValue :: 'Value' Gender +-- genderValue = +-- 'contramap' genderText 'text' +-- where +-- genderText gender = +-- case gender of +-- Male -> "male" +-- Female -> "female" +-- @ +-- +newtype Params a = + Params (Params.Params a) + deriving (Contravariant, Divisible, Monoid) + +-- | +-- Encode no parameters. +-- +{-# INLINABLE unit #-} +unit :: Params () +unit = + Params mempty + +-- | +-- Lift an individual value encoder to a parameters encoder. +-- +{-# INLINABLE value #-} +value :: Value a -> Params a +value (Value x) = + Params (Params.value x) + +-- | +-- Lift an individual nullable value encoder to a parameters encoder. +-- +{-# INLINABLE nullableValue #-} +nullableValue :: Value a -> Params (Maybe a) +nullableValue (Value x) = + Params (Params.nullableValue x) + + +-- ** Instances +------------------------- + +-- | +-- Maps to 'unit'. +instance Default (Params ()) where + {-# INLINE def #-} + def = + unit + +instance Default (Value a) => Default (Params (Identity a)) where + {-# INLINE def #-} + def = + contramap runIdentity (value def) + +instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where + {-# INLINE def #-} + def = + contrazip2 (value def) (value def) + +instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where + {-# INLINE def #-} + def = + contrazip3 (value def) (value def) (value def) + +instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where + {-# INLINE def #-} + def = + contrazip4 (value def) (value def) (value def) (value def) + +instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where + {-# INLINE def #-} + def = + contrazip5 (value def) (value def) (value def) (value def) (value def) + + +-- * Value Encoder +------------------------- + +-- | +-- An individual value encoder. +-- Will be mapped to a single placeholder in the query. +-- +newtype Value a = + Value (Value.Value a) + deriving (Contravariant) + +-- | +-- Encoder of @BOOL@ values. +{-# INLINABLE bool #-} +bool :: Value Bool +bool = + Value (Value.unsafePTI PTI.bool (const Encoder.bool)) + +-- | +-- Encoder of @INT2@ values. +{-# INLINABLE int2 #-} +int2 :: Value Int16 +int2 = + Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16)) + +-- | +-- Encoder of @INT4@ values. +{-# INLINABLE int4 #-} +int4 :: Value Int32 +int4 = + Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32)) + +-- | +-- Encoder of @INT8@ values. +{-# INLINABLE int8 #-} +int8 :: Value Int64 +int8 = + Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64)) + +-- | +-- Encoder of @FLOAT4@ values. +{-# INLINABLE float4 #-} +float4 :: Value Float +float4 = + Value (Value.unsafePTI PTI.float4 (const Encoder.float4)) + +-- | +-- Encoder of @FLOAT8@ values. +{-# INLINABLE float8 #-} +float8 :: Value Double +float8 = + Value (Value.unsafePTI PTI.float8 (const Encoder.float8)) + +-- | +-- Encoder of @NUMERIC@ values. +{-# INLINABLE numeric #-} +numeric :: Value Scientific +numeric = + Value (Value.unsafePTI PTI.numeric (const Encoder.numeric)) + +-- | +-- Encoder of @CHAR@ values. +-- Note that it supports UTF-8 values and +-- identifies itself under the @TEXT@ OID because of that. +{-# INLINABLE char #-} +char :: Value Char +char = + Value (Value.unsafePTI PTI.text (const Encoder.char)) + +-- | +-- Encoder of @TEXT@ values. +{-# INLINABLE text #-} +text :: Value Text +text = + Value (Value.unsafePTI PTI.text (const Encoder.text_strict)) + +-- | +-- Encoder of @BYTEA@ values. +{-# INLINABLE bytea #-} +bytea :: Value ByteString +bytea = + Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict)) + +-- | +-- Encoder of @DATE@ values. +{-# INLINABLE date #-} +date :: Value Day +date = + Value (Value.unsafePTI PTI.date (const Encoder.date)) + +-- | +-- Encoder of @TIMESTAMP@ values. +{-# INLINABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = + Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float)) + +-- | +-- Encoder of @TIMESTAMPTZ@ values. +{-# INLINABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = + Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float)) + +-- | +-- Encoder of @TIME@ values. +{-# INLINABLE time #-} +time :: Value TimeOfDay +time = + Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float)) + +-- | +-- Encoder of @TIMETZ@ values. +{-# INLINABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = + Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float)) + +-- | +-- Encoder of @INTERVAL@ values. +{-# INLINABLE interval #-} +interval :: Value DiffTime +interval = + Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float)) + +-- | +-- Encoder of @UUID@ values. +{-# INLINABLE uuid #-} +uuid :: Value UUID +uuid = + Value (Value.unsafePTI PTI.uuid (const Encoder.uuid)) + +-- | +-- Encoder of @JSON@ values. +{-# INLINABLE json #-} +json :: Value Aeson.Value +json = + Value (Value.unsafePTI PTI.json (const Encoder.json)) + +-- | +-- Unlifts the 'Array' encoder to the plain 'Value' encoder. +{-# INLINABLE array #-} +array :: Array a -> Value a +array (Array imp) = + Array.run imp & \(arrayOID, encoder') -> + Value (Value.Value arrayOID arrayOID encoder') + +-- | +-- Given a function, +-- which maps the value into the textual enum label from the DB side, +-- produces a encoder of that value. +{-# INLINABLE enum #-} +enum :: (a -> Text) -> Value a +enum mapping = + Value (Value.unsafePTI PTI.text (const (Encoder.enum mapping))) + + +-- ** Instances +------------------------- + +-- | Maps to 'bool'. +instance Default (Value Bool) where + {-# INLINE def #-} + def = + bool + +-- | Maps to 'int2'. +instance Default (Value Int16) where + {-# INLINE def #-} + def = + int2 + +-- | Maps to 'int4'. +instance Default (Value Int32) where + {-# INLINE def #-} + def = + int4 + +-- | Maps to 'int8'. +instance Default (Value Int64) where + {-# INLINE def #-} + def = + int8 + +-- | Maps to 'float4'. +instance Default (Value Float) where + {-# INLINE def #-} + def = + float4 + +-- | Maps to 'float8'. +instance Default (Value Double) where + {-# INLINE def #-} + def = + float8 + +-- | Maps to 'numeric'. +instance Default (Value Scientific) where + {-# INLINE def #-} + def = + numeric + +-- | Maps to 'char'. +instance Default (Value Char) where + {-# INLINE def #-} + def = + char + +-- | Maps to 'text'. +instance Default (Value Text) where + {-# INLINE def #-} + def = + text + +-- | Maps to 'bytea'. +instance Default (Value ByteString) where + {-# INLINE def #-} + def = + bytea + +-- | Maps to 'date'. +instance Default (Value Day) where + {-# INLINE def #-} + def = + date + +-- | Maps to 'timestamp'. +instance Default (Value LocalTime) where + {-# INLINE def #-} + def = + timestamp + +-- | Maps to 'timestamptz'. +instance Default (Value UTCTime) where + {-# INLINE def #-} + def = + timestamptz + +-- | Maps to 'time'. +instance Default (Value TimeOfDay) where + {-# INLINE def #-} + def = + time + +-- | Maps to 'timetz'. +instance Default (Value (TimeOfDay, TimeZone)) where + {-# INLINE def #-} + def = + timetz + +-- | Maps to 'interval'. +instance Default (Value DiffTime) where + {-# INLINE def #-} + def = + interval + +-- | Maps to 'uuid'. +instance Default (Value UUID) where + {-# INLINE def #-} + def = + uuid + +-- | Maps to 'json'. +instance Default (Value Aeson.Value) where + {-# INLINE def #-} + def = + json + + +-- * Array +------------------------- + +-- | +-- A generic array encoder. +-- +-- Here's an example of its usage: +-- +-- >x :: Value [[Int64]] +-- >x = +-- > array (arrayDimension foldl' (arrayDimension foldl' (arrayValue int8))) +-- +newtype Array a = + Array (Array.Array a) + +-- | +-- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value. +{-# INLINABLE arrayValue #-} +arrayValue :: Value a -> Array a +arrayValue (Value (Value.Value elementOID arrayOID encoder')) = + Array (Array.value elementOID arrayOID encoder') + +-- | +-- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value. +{-# INLINABLE arrayNullableValue #-} +arrayNullableValue :: Value a -> Array (Maybe a) +arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) = + Array (Array.nullableValue elementOID arrayOID encoder') + +-- | +-- An encoder of an array dimension, +-- which thus provides support for multidimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the left-fold operation, +-- such as @Data.Foldable.'foldl''@, +-- which determines the input value. +-- +-- * A component encoder, which can be either another 'arrayDimension', +-- 'arrayValue' or 'arrayNullableValue'. +-- +{-# INLINABLE arrayDimension #-} +arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +arrayDimension foldl (Array imp) = + Array (Array.dimension foldl imp) + diff --git a/library/Hasql/Encoding/Array.hs b/library/Hasql/Encoding/Array.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoding/Array.hs @@ -0,0 +1,31 @@ +module Hasql.Encoding.Array where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.PTI as PTI + + +data Array a = + Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a) + +{-# INLINE run #-} +run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a) +run (Array valueOID arrayOID encoder') = + (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env)) + +{-# INLINE value #-} +value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a +value valueOID arrayOID encoder' = + Array valueOID arrayOID (Encoder.arrayValue . encoder') + +{-# INLINE nullableValue #-} +nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a) +nullableValue valueOID arrayOID encoder' = + Array valueOID arrayOID (Encoder.arrayNullableValue . encoder') + +{-# INLINE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension foldl (Array valueOID arrayOID encoder') = + Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder') + diff --git a/library/Hasql/Encoding/Params.hs b/library/Hasql/Encoding/Params.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoding/Params.hs @@ -0,0 +1,49 @@ +module Hasql.Encoding.Params where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.Encoding.Value as Value +import qualified Hasql.PTI as PTI + + +-- | +-- Encoder of some representation of a parameters product. +newtype Params a = + Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a) + deriving (Contravariant, Divisible, Monoid) + +run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString) +run (Params (Op op)) params = + {-# SCC "run" #-} + op params + +run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)]) +run' (Params (Op op)) params integerDatetimes = + {-# SCC "run'" #-} + foldr step ([], []) (op params) + where + step (oid, bytesGetter) ~(oidList, bytesAndFormatList) = + (,) + (oid : oidList) + (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList) + +run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] +run'' (Params (Op op)) params integerDatetimes = + {-# SCC "run''" #-} + foldr step [] (op params) + where + step a b = + mapping a : b + where + mapping (oid, bytesGetter) = + (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary + +value :: Value.Value a -> Params a +value = + contramap Just . nullableValue + +nullableValue :: Value.Value a -> Params (Maybe a) +nullableValue (Value.Value valueOID arrayOID encoder') = + Params $ Op $ \input -> + pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input) diff --git a/library/Hasql/Encoding/Value.hs b/library/Hasql/Encoding/Value.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoding/Value.hs @@ -0,0 +1,27 @@ +module Hasql.Encoding.Value where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.PTI as PTI + + +data Value a = + Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a) + +instance Contravariant Value where + {-# INLINE contramap #-} + contramap f (Value valueOID arrayOID encoder) = + Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input)) + +{-# INLINE run #-} +run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a) +run (Value valueOID arrayOID encoder') = + (valueOID, arrayOID, encoder') + +{-# INLINE unsafePTI #-} +unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a +unsafePTI pti encoder' = + Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder' + + diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/IO.hs @@ -0,0 +1,151 @@ +-- | +-- An API of low-level IO operations. +module Hasql.IO +where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Commands as Commands +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.Decoding.Result as ResultDecoding +import qualified Hasql.Decoding.Results as ResultsDecoding +import qualified Hasql.Encoding.Params as ParamsEncoding +import qualified Data.DList as DList + + +{-# INLINE acquireConnection #-} +acquireConnection :: ByteString -> IO LibPQ.Connection +acquireConnection = + LibPQ.connectdb + +{-# INLINE acquirePreparedStatementRegistry #-} +acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry +acquirePreparedStatementRegistry = + PreparedStatementRegistry.new + +{-# INLINE releaseConnection #-} +releaseConnection :: LibPQ.Connection -> IO () +releaseConnection connection = + LibPQ.finish connection + +{-# INLINE checkConnectionStatus #-} +checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString)) +checkConnectionStatus c = + do + s <- LibPQ.status c + case s of + LibPQ.ConnectionOk -> return Nothing + _ -> fmap Just (LibPQ.errorMessage c) + +{-# INLINE checkServerVersion #-} +checkServerVersion :: LibPQ.Connection -> IO (Maybe Int) +checkServerVersion c = + fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c) + +{-# INLINE getIntegerDatetimes #-} +getIntegerDatetimes :: LibPQ.Connection -> IO Bool +getIntegerDatetimes c = + fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes" + where + decodeValue = + \case + Just "on" -> True + _ -> False + +{-# INLINE initConnection #-} +initConnection :: LibPQ.Connection -> IO () +initConnection c = + void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodingToUTF8 <> Commands.setMinClientMessagesToWarning)) + +{-# INLINE getResults #-} +getResults :: LibPQ.Connection -> Bool -> ResultsDecoding.Results a -> IO (Either ResultsDecoding.Error a) +getResults connection integerDatetimes des = + {-# SCC "getResults" #-} + ResultsDecoding.run (des <* ResultsDecoding.dropRemainders) (integerDatetimes, connection) + +{-# INLINE getPreparedStatementKey #-} +getPreparedStatementKey :: + LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> [LibPQ.Oid] -> + IO (Either ResultsDecoding.Error ByteString) +getPreparedStatementKey connection registry template oidList = + {-# SCC "getPreparedStatementKey" #-} + do + keyMaybe <- PreparedStatementRegistry.lookup template wordOIDList registry + case keyMaybe of + Just key -> + pure (pure key) + Nothing -> + do + key <- PreparedStatementRegistry.register template wordOIDList registry + sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) + let resultsDecoder = + if sent + then ResultsDecoding.single ResultDecoding.unit + else ResultsDecoding.clientError + runEitherT $ do + EitherT $ getResults connection undefined resultsDecoder + pure key + where + wordOIDList = + map (\(LibPQ.Oid x) -> fromIntegral x) oidList + +{-# INLINE checkedSend #-} +checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoding.Error ()) +checkedSend connection send = + send >>= \case + False -> fmap (Left . ResultsDecoding.ClientError) $ LibPQ.errorMessage connection + True -> pure (Right ()) + +{-# INLINE sendPreparedParametricQuery #-} +sendPreparedParametricQuery :: + LibPQ.Connection -> + PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> + [LibPQ.Oid] -> + [Maybe (ByteString, LibPQ.Format)] -> + IO (Either ResultsDecoding.Error ()) +sendPreparedParametricQuery connection registry template oidList valueAndFormatList = + runEitherT $ do + key <- EitherT $ getPreparedStatementKey connection registry template oidList + EitherT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary + +{-# INLINE sendUnpreparedParametricQuery #-} +sendUnpreparedParametricQuery :: + LibPQ.Connection -> + ByteString -> + [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] -> + IO (Either ResultsDecoding.Error ()) +sendUnpreparedParametricQuery connection template paramList = + checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary + +{-# INLINE sendParametricQuery #-} +sendParametricQuery :: + LibPQ.Connection -> + Bool -> + PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> + ParamsEncoding.Params a -> + Bool -> + a -> + IO (Either ResultsDecoding.Error ()) +sendParametricQuery connection integerDatetimes registry template encoder prepared params = + {-# SCC "sendParametricQuery" #-} + if prepared + then + let + (oidList, valueAndFormatList) = + ParamsEncoding.run' encoder params integerDatetimes + in + sendPreparedParametricQuery connection registry template oidList valueAndFormatList + else + let + paramList = + ParamsEncoding.run'' encoder params integerDatetimes + in + sendUnpreparedParametricQuery connection template paramList + +{-# INLINE sendNonparametricQuery #-} +sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoding.Error ()) +sendNonparametricQuery connection sql = + checkedSend connection $ LibPQ.sendQuery connection sql diff --git a/library/Hasql/PTI.hs b/library/Hasql/PTI.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/PTI.hs @@ -0,0 +1,93 @@ +module Hasql.PTI where + +import Hasql.Prelude hiding (bool) +import qualified Database.PostgreSQL.LibPQ as LibPQ + + +-- | A Postgresql type info +data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) } + +-- | A Word32 and a LibPQ representation of an OID +data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid } + +mkOID :: Word32 -> OID +mkOID x = + OID x ((LibPQ.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) + diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs --- a/library/Hasql/Prelude.hs +++ b/library/Hasql/Prelude.hs @@ -1,53 +1,134 @@ module Hasql.Prelude -( +( module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + bug, + bottom, + forMToZero_, + forMFromZero_, + strictCons, ) where -- base-prelude ------------------------- -import BasePrelude as Exports hiding (left, right, isLeft, isRight) +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) -- transformers ------------------------- -import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) -import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) -import Control.Monad.Trans.Writer as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) -import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) -import Control.Monad.Trans.Class as Exports import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) import Data.Functor.Identity as Exports --- transformers-base +-- data-default-class ------------------------- -import Control.Monad.Base as Exports +import Data.Default.Class as Exports --- monad-control +-- profunctors ------------------------- -import Control.Monad.Trans.Control as Exports hiding (embed, embed_) +import Data.Profunctor.Unsafe as Exports --- mtl +-- contravariant ------------------------- -import Control.Monad.Error.Class as Exports hiding (Error) +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports --- mmorph +-- contravariant-extras ------------------------- -import Control.Monad.Morph as Exports +import Contravariant.Extras as Exports -- either ------------------------- import Control.Monad.Trans.Either as Exports import Data.Either.Combinators as Exports --- list-t +-- hashable ------------------------- -import ListT as Exports (ListT) +import Data.Hashable as Exports (Hashable(..)) +-- text +------------------------- +import Data.Text as Exports (Text) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +-- uuid +------------------------- +import Data.UUID as Exports (UUID) + +-- time +------------------------- +import Data.Time as Exports + -- vector ------------------------- import Data.Vector as Exports (Vector) --- text +-- dlist ------------------------- -import Data.Text as Exports (Text) +import Data.DList as Exports (DList) + +-- placeholders +------------------------- +import Development.Placeholders as Exports + +-- loch-th +------------------------- +import Debug.Trace.LocationTH as Exports + +-- custom +------------------------- +import qualified Debug.Trace.LocationTH +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Builder + + +type LazyByteString = + Data.ByteString.Lazy.ByteString + +type ByteStringBuilder = + Data.ByteString.Builder.Builder + +type LazyText = + Data.Text.Lazy.Text + +type TextBuilder = + Data.Text.Lazy.Builder.Builder + +bug = + [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] + where + msg = "A \"hasql\" package bug: " :: String + +bottom = + [e| $bug "Bottom evaluated" |] + +{-# INLINE forMToZero_ #-} +forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m () +forMToZero_ !startN f = + ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure () + +{-# INLINE forMFromZero_ #-} +forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m () +forMFromZero_ !endN f = + ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure () + +{-# INLINE strictCons #-} +strictCons :: a -> [a] -> [a] +strictCons !a b = + let !c = a : b in c diff --git a/library/Hasql/PreparedStatementRegistry.hs b/library/Hasql/PreparedStatementRegistry.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/PreparedStatementRegistry.hs @@ -0,0 +1,46 @@ +module Hasql.PreparedStatementRegistry +( + PreparedStatementRegistry, + new, + lookup, + register, +) +where + +import Hasql.Prelude hiding (lookup) +import qualified Data.HashTable.IO as Hashtables + + +data PreparedStatementRegistry = + PreparedStatementRegistry !(Hashtables.BasicHashTable LocalKey ByteString) !(IORef Word) + +{-# INLINABLE new #-} +new :: IO PreparedStatementRegistry +new = + PreparedStatementRegistry <$> Hashtables.new <*> newIORef 0 + +{-# INLINABLE lookup #-} +lookup :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO (Maybe ByteString) +lookup template oids (PreparedStatementRegistry table counter) = + Hashtables.lookup table (LocalKey template oids) + +{-# INLINABLE register #-} +register :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO ByteString +register template oids (PreparedStatementRegistry table counter) = + do + n <- readIORef counter + writeIORef counter (succ n) + let remoteKey = fromString (show n) + Hashtables.insert table (LocalKey template oids) remoteKey + return remoteKey + +-- | +-- Local statement key. +data LocalKey = + LocalKey !ByteString ![Word32] + deriving (Show, Eq) + +instance Hashable LocalKey where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (LocalKey template types) = + hashWithSalt salt template diff --git a/library/Hasql/QQ.hs b/library/Hasql/QQ.hs deleted file mode 100644 --- a/library/Hasql/QQ.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Hasql.QQ where - -import Hasql.Prelude -import Hasql.TH -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import qualified Data.Text as Text -import qualified Hasql.QQ.Parser as Parser -import qualified Hasql.Backend as Bknd - - --- | --- Produces a lambda-expression, --- which takes as many parameters as there are placeholders in the quoted text --- and results in a 'Bknd.Stmt'. --- --- E.g.: --- --- >selectSum :: Int -> Int -> Stmt c --- >selectSum = [stmt|SELECT (? + ?)|] --- --- It also allows to directly refer to free variables like so: --- --- >selectSum :: Int -> Int -> Stmt c --- >selectSum a b = [stmt|SELECT ($a + $b)|] -stmt :: QuasiQuoter -stmt = - QuasiQuoter - (parseExp) - (const $ fail "Pattern context is not supported") - (const $ fail "Type context is not supported") - (const $ fail "Declaration context is not supported") - where - parseExp = - fmap (uncurry statementF) . - either (fail . showString "Parsing failure: ") return . - Parser.parse . - fromString - statementF t params = - LamE - (map VarP argNames) - (purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|]) - where - (varNames, argNames) = - (\(a, b) -> (reverse a, reverse b)) $ - flip execState ([], []) $ forM_ params $ \case - Parser.ParamName n -> - modify $ \(a, b) -> (mkName (Text.unpack n) : a, b) - Parser.OrderedPlaceholder -> - modify $ \(a, b) -> - let n = mkName $ '_' : show (length b + 1) - in (n : a, n : b) - Parser.IndexedPlaceholder i -> - fail "Indexed placeholders are not supported" - statementE = - LitE (StringL (Text.unpack t)) - argsE = - vectorE $ - map (\x -> purify [| Bknd.encodeValue $(varE x) |]) $ - varNames diff --git a/library/Hasql/QQ/Parser.hs b/library/Hasql/QQ/Parser.hs deleted file mode 100644 --- a/library/Hasql/QQ/Parser.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Hasql.QQ.Parser where - -import Hasql.Prelude hiding (takeWhile) -import Data.Attoparsec.Text hiding (Result) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB - - -type Result = - (Text, [Param]) - -data Param = - ParamName Text | - OrderedPlaceholder | - IndexedPlaceholder Int - --- | --- Produces a whitespace-cleaned text and a count of placeholders in it. -parse :: Text -> Either String (Text, [Param]) -parse = - parseOnly $ singleTemplate - -singleTemplate :: Parser (Text, [Param]) -singleTemplate = - template <* - ((endOfInput) <|> - (() <$ skipSpace <* char ';' <* fail "A semicolon detected, but only single statements are allowed")) - -template :: Parser (Text, [Param]) -template = - runWriterT $ do - lift $ skipSpace - fmap (TL.toStrict . TLB.toLazyText . mconcat) $ - many $ - (mempty <$ lift (takeWhile1 isSpace <* endOfInput)) <|> - (TLB.singleton ' ' <$ lift (takeWhile1 isSpace)) <|> - (TLB.fromText <$> lift stringLit) <|> - (TLB.singleton '?' <$ (lift param >>= tell . pure)) <|> - (TLB.singleton <$> lift (notChar ';')) - -stringLit :: Parser Text -stringLit = - do - quote <- - char '"' <|> char '\'' - content <- - fmap mconcat $ many $ - TLB.fromText <$> string "\\\\" <|> - TLB.fromText <$> string (fromString ['\\', quote]) <|> - TLB.singleton <$> notChar quote - char quote - return $ TL.toStrict . TLB.toLazyText $ - TLB.singleton quote <> content <> TLB.singleton quote - -param :: Parser Param -param = - (char '$' *> ((ParamName <$> paramName) <|> (IndexedPlaceholder <$> decimal))) <|> - (OrderedPlaceholder <$ char '?') - -paramName :: Parser Text -paramName = - T.cons <$> satisfy isLower <*> takeWhile (\c -> isAlphaNum c || elem c extraChars) - where - extraChars = "_'" :: [Char] diff --git a/library/Hasql/Query.hs b/library/Hasql/Query.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Query.hs @@ -0,0 +1,165 @@ +module Hasql.Query +( + Query(..), + -- * Execution + ResultsError(..), + ResultError(..), + RowError(..), + run, +) +where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.Decoding.Results as ResultsDecoding +import qualified Hasql.Decoding as Decoding +import qualified Hasql.Encoding.Params as ParamsEncoding +import qualified Hasql.Encoding as Encoding +import qualified Hasql.Settings as Settings +import qualified Hasql.IO as IO +import qualified Hasql.Connection.Impl as Connection + + +-- | +-- An error of the result-decoder. +data ResultsError = + -- | + -- An error on the client-side, + -- with a message generated by the \"libpq\" library. + -- Usually indicates problems with connection. + ClientError !(Maybe ByteString) | + -- | + -- Decoder error details. + ResultError !ResultError + deriving (Show, Eq) + +-- | +-- Decoder error details. +data ResultError = + -- | + -- An error reported by the DB. + -- Consists of the following: Code, message, details, hint. + -- + -- * __Code__. + -- The SQLSTATE code for the error. + -- It's recommended to use + -- + -- to work with those. + -- + -- * __Message__. + -- The primary human-readable error message (typically one line). Always present. + -- + -- * __Details__. + -- An optional secondary error message carrying more detail about the problem. + -- Might run to multiple lines. + -- + -- * __Hint__. + -- An optional suggestion on what to do about the problem. + -- This is intended to differ from detail in that it offers advice (potentially inappropriate) + -- rather than hard facts. + -- Might run to multiple lines. + ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | + -- | + -- The database returned an unexpected result. + -- Indicates an improper statement or a schema mismatch. + UnexpectedResult !Text | + -- | + -- An error of the row reader, preceded by the index of the row. + RowError !Int !RowError | + -- | + -- An unexpected amount of rows. + UnexpectedAmountOfRows !Int + deriving (Show, Eq) + +-- | +-- An error during the decoding of a specific row. +data RowError = + -- | + -- Appears on the attempt to parse more columns than there are in the result. + EndOfInput | + -- | + -- Appears on the attempt to parse a @NULL@ as some value. + UnexpectedNull | + -- | + -- Appears when a wrong value parser is used. + -- Comes with the error details. + ValueError !Text + deriving (Show, Eq) + + +-- | +-- A specification of a strictly single-statement query, which can be parameterized and prepared. +-- +-- Consists of the following: +-- +-- * SQL template, +-- * params encoder, +-- * result decoder, +-- * a flag, determining whether it should be prepared. +-- +-- The SQL template must be formatted according to Postgres' standard, +-- with any non-ASCII characters of the template must be encoded using UTF-8. +-- According to the format, +-- parameters must be referred to using the positional notation, as in the following: +-- @$1@, @$2@, @$3@ and etc. +-- Those references must be used to refer to the values of the 'Encoding.Params' encoder. +-- +-- Following is an example of the declaration of a prepared statement with its associated codecs. +-- +-- @ +-- selectSum :: Hasql.'Hasql.Query' (Int64, Int64) Int64 +-- selectSum = +-- Hasql.'Hasql.Query' sql encoder decoder True +-- where +-- sql = +-- "select ($1 + $2)" +-- encoder = +-- 'contramap' 'fst' (Hasql.Encoding.'Hasql.Encoding.value' Hasql.Encoding.'Hasql.Encoding.int8') '<>' +-- 'contramap' 'snd' (Hasql.Encoding.'Hasql.Encoding.value' Hasql.Encoding.'Hasql.Encoding.int8') +-- decoder = +-- Hasql.Decoding.'Hasql.Decoding.singleRow' (Hasql.Decoding.'Hasql.Decoding.value' Hasql.Decoding.'Hasql.Decoding.int8') +-- @ +-- +-- The statement above accepts a product of two parameters of type 'Int64' +-- and results in a single result of type 'Int64'. +-- +data Query a b = + Query !ByteString !(Encoding.Params a) !(Decoding.Result b) !Bool + deriving (Functor) + +instance Profunctor Query where + {-# INLINE lmap #-} + lmap f (Query p1 p2 p3 p4) = + Query p1 (contramap f p2) p3 p4 + {-# INLINE rmap #-} + rmap f (Query p1 p2 p3 p4) = + Query p1 p2 (fmap f p3) p4 + {-# INLINE dimap #-} + dimap f1 f2 (Query p1 p2 p3 p4) = + Query p1 (contramap f1 p2) (fmap f2 p3) p4 + +-- | +-- Execute the query, producing either a deserialization failure or a successful result. +run :: Query a b -> a -> Connection.Connection -> IO (Either ResultsError b) +run (Query template encoder decoder preparable) params (Connection.Connection pqConnection integerDatetimes registry) = + {-# SCC "query" #-} + fmap (mapLeft coerceResultsError) $ runEitherT $ do + EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params + EitherT $ IO.getResults pqConnection integerDatetimes (coerceDecoder decoder) + +-- | +-- WARNING: We need to take special care that the structure of +-- the "ResultsDecoding.Error" type in the public API is an exact copy of +-- "Error", since we're using coercion. +coerceResultsError :: ResultsDecoding.Error -> ResultsError +coerceResultsError = + unsafeCoerce + +coerceDecoder :: Decoding.Result a -> ResultsDecoding.Results a +coerceDecoder = + unsafeCoerce + +coerceEncoder :: Encoding.Params a -> ParamsEncoding.Params a +coerceEncoder = + unsafeCoerce diff --git a/library/Hasql/Settings.hs b/library/Hasql/Settings.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Settings.hs @@ -0,0 +1,39 @@ +module Hasql.Settings where + +import Hasql.Prelude +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Builder as BB +import qualified Data.ByteString.Lazy.Builder.ASCII as BB +import qualified Data.ByteString.Lazy as BL + + + +-- | +-- All settings encoded in a single byte-string according to +-- . +type Settings = + ByteString + +-- | +-- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string. +{-# INLINE settings #-} +settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings +settings host port user password database = + BL.toStrict $ BB.toLazyByteString $ mconcat $ intersperse (BB.char7 ' ') $ catMaybes $ + [ + mappend (BB.string7 "host=") . BB.byteString <$> + mfilter (not . B.null) (pure host) + , + mappend (BB.string7 "port=") . BB.word16Dec <$> + mfilter (/= 0) (pure port) + , + mappend (BB.string7 "user=") . BB.byteString <$> + mfilter (not . B.null) (pure user) + , + mappend (BB.string7 "password=") . BB.byteString <$> + mfilter (not . B.null) (pure password) + , + mappend (BB.string7 "dbname=") . BB.byteString <$> + mfilter (not . B.null) (pure database) + ] + diff --git a/library/Hasql/TH.hs b/library/Hasql/TH.hs deleted file mode 100644 --- a/library/Hasql/TH.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- TH utils. -module Hasql.TH where - -import Hasql.Prelude -import Language.Haskell.TH -import qualified Data.Vector as Vector -import qualified Data.Vector.Mutable as MVector - - -applicativeE :: Exp -> [Exp] -> Exp -applicativeE head = - \case - [] -> error "Empty expressions list" - exps -> - reduce $ - head : VarE '(<$>) : intersperse (VarE '(<*>)) exps - where - reduce = - \case - e : o : t -> UInfixE e o (reduce t) - e : [] -> e - _ -> error $ "Unexpected queue size. Exps: " <> show exps - -purify :: Q a -> a -purify = unsafePerformIO . runQ - --- | --- Produce a lambda expression of a given arity, --- which efficiently constructs a vector of a size equal to the arity. -vectorLamE :: Int -> Exp -vectorLamE arity = - LamE (map VarP argNames) body - where - argNames = - map (mkName . ('_' :) . show) [1 .. arity] - body = - vectorE $ map VarE argNames - -vectorE :: [Exp] -> Exp -vectorE cellExps = - if null cellExps - then - VarE 'Vector.empty - else - AppE (VarE 'runST) $ DoE $ - pure vectorDeclarationStmt <> cellAssignmentStmts <> pure freezingStmt - where - vectorVarName = - mkName "v" - vectorDeclarationStmt = - (BindS - (VarP vectorVarName) - (AppE - (VarE 'MVector.unsafeNew) - (LitE (IntegerL (fromIntegral (length cellExps)))))) - cellAssignmentStmts = - map (NoBindS . uncurry cellAssignmentExp) $ zip [0..] cellExps - where - cellAssignmentExp index exp = - (AppE - (AppE - (AppE - (VarE 'MVector.unsafeWrite) - (VarE vectorVarName)) - (LitE (IntegerL (fromIntegral index)))) - (exp)) - freezingStmt = - (NoBindS - (AppE - (VarE 'Vector.unsafeFreeze) - (VarE vectorVarName))) - -classP :: Name -> [Type] -> Pred -#if MIN_VERSION_template_haskell(2,10,0) -classP n tl = foldl AppT (ConT n) tl -#else -classP = ClassP -#endif diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,136 @@ +module Main where + +import Main.Prelude hiding (assert, isRight, isLeft) +import Test.QuickCheck.Instances +import Test.Tasty +import qualified Main.Queries as Queries +import qualified Test.Tasty.HUnit as HUnit +import qualified Test.Tasty.SmallCheck as SmallCheck +import qualified Test.Tasty.QuickCheck as QuickCheck +import qualified Test.QuickCheck as QuickCheck +import qualified Main.DSL as DSL +import qualified Hasql.Query as Query +import qualified Hasql.Encoding as Encoding +import qualified Hasql.Decoding as Decoding + +main = + defaultMain tree + +tree = + testGroup "All tests" + [ + HUnit.testCase "Enum" $ + HUnit.assertEqual "" (Right "ok") $ + let + actual = + unsafePerformIO $ + DSL.session $ do + let + query = + Query.Query sql mempty Decoding.unit True + where + sql = + "drop type if exists mood" + in DSL.query () query + let + query = + Query.Query sql mempty Decoding.unit True + where + sql = + "create type mood as enum ('sad', 'ok', 'happy')" + in DSL.query () query + let + query = + Query.Query sql encoder decoder True + where + sql = + "select ($1 :: mood)" + decoder = + (Decoding.singleRow (Decoding.value (Decoding.enum (Just . id)))) + encoder = + Encoding.value (Encoding.enum id) + in DSL.query "ok" query + in actual + , + HUnit.testCase "The same prepared statement used on different types" $ + HUnit.assertEqual "" (Right ("ok", 1)) $ + let + actual = + unsafePerformIO $ + DSL.session $ do + let + effect1 = + DSL.query "ok" query + where + query = + Query.Query sql encoder decoder True + where + sql = + "select $1" + encoder = + Encoding.value Encoding.text + decoder = + (Decoding.singleRow (Decoding.value (Decoding.text))) + effect2 = + DSL.query 1 query + where + query = + Query.Query sql encoder decoder True + where + sql = + "select $1" + encoder = + Encoding.value Encoding.int8 + decoder = + (Decoding.singleRow (Decoding.value Decoding.int8)) + in (,) <$> effect1 <*> effect2 + in actual + , + HUnit.testCase "Affected rows counting" $ + HUnit.assertEqual "" (Right 100) $ + let + actual = + unsafePerformIO $ + DSL.session $ do + dropTable + createTable + replicateM_ 100 insertRow + deleteRows <* dropTable + where + dropTable = + DSL.query () $ Queries.plain $ + "drop table if exists a" + createTable = + DSL.query () $ Queries.plain $ + "create table a (id bigserial not null, name varchar not null, primary key (id))" + insertRow = + DSL.query () $ Queries.plain $ + "insert into a (name) values ('a')" + deleteRows = + DSL.query () $ Query.Query sql def decoder False + where + sql = + "delete from a" + decoder = + Decoding.rowsAffected + in actual + , + HUnit.testCase "Result of an auto-incremented column" $ + let + actualIO = + DSL.session $ do + DSL.query () $ Queries.plain $ "drop table if exists a" + DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))" + id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False + id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False + DSL.query () $ Queries.plain $ "drop table if exists a" + pure (id1, id2) + in HUnit.assertEqual "" (Right (1, 2)) =<< actualIO + , + HUnit.testCase "List decoding" $ + let + actualIO = + DSL.session $ DSL.query () $ Queries.selectList + in HUnit.assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO + ] + diff --git a/tasty/Main/DSL.hs b/tasty/Main/DSL.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/DSL.hs @@ -0,0 +1,43 @@ +module Main.DSL where + +import Main.Prelude +import qualified Hasql.Connection as HC +import qualified Hasql.Query as HQ +import qualified Hasql.Settings as HS +import qualified Hasql.Encoding as HE +import qualified Hasql.Decoding as HD + + +newtype Session a = + Session (ReaderT HC.Connection (EitherT HQ.ResultsError IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +data SessionError = + ConnectionError (HC.ConnectionError) | + ResultsError (HQ.ResultsError) + deriving (Show, Eq) + +session :: Session a -> IO (Either SessionError a) +session (Session impl) = + runEitherT $ acquire >>= \connection -> use connection <* release connection + where + acquire = + EitherT $ fmap (mapLeft ConnectionError) $ HC.acquire settings + where + settings = + HS.settings host port user password database + where + host = "localhost" + port = 5432 + user = "postgres" + password = "" + database = "postgres" + use connection = + bimapEitherT ResultsError id $ + runReaderT impl connection + release connection = + lift $ HC.release connection + +query :: a -> HQ.Query a b -> Session b +query params query = + Session $ ReaderT $ EitherT . HQ.run query params diff --git a/tasty/Main/Prelude.hs b/tasty/Main/Prelude.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Prelude.hs @@ -0,0 +1,73 @@ +module Main.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) + +-- transformers +------------------------- +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Data.Functor.Identity as Exports + +-- data-default-class +------------------------- +import Data.Default.Class as Exports + +-- profunctors +------------------------- +import Data.Profunctor.Unsafe as Exports + +-- contravariant +------------------------- +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports + +-- contravariant-extras +------------------------- +import Contravariant.Extras as Exports + +-- either +------------------------- +import Control.Monad.Trans.Either as Exports +import Data.Either.Combinators as Exports + +-- hashable +------------------------- +import Data.Hashable as Exports (Hashable(..)) + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +-- uuid +------------------------- +import Data.UUID as Exports (UUID) + +-- time +------------------------- +import Data.Time as Exports + +-- vector +------------------------- +import Data.Vector as Exports (Vector) + +-- dlist +------------------------- +import Data.DList as Exports (DList) diff --git a/tasty/Main/Queries.hs b/tasty/Main/Queries.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Queries.hs @@ -0,0 +1,36 @@ +module Main.Queries where + +import Main.Prelude hiding (def) +import qualified Hasql.Query as HQ +import qualified Hasql.Encoding as HE +import qualified Hasql.Decoding as HD +import qualified Main.Prelude as Prelude + + +def :: ByteString -> HQ.Query () () +def sql = + HQ.Query sql Prelude.def Prelude.def False + +plain :: ByteString -> HQ.Query () () +plain sql = + HQ.Query sql mempty HD.unit False + +dropType :: ByteString -> HQ.Query () () +dropType name = + plain $ + "drop type if exists " <> name + +createEnum :: ByteString -> [ByteString] -> HQ.Query () () +createEnum name values = + plain $ + "create type " <> name <> " as enum (" <> + mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) <> ")" + +selectList :: HQ.Query () ([] (Int64, Int64)) +selectList = + HQ.Query sql mempty decoder True + where + sql = + "values (1,2), (3,4), (5,6)" + decoder = + HD.rowsList ((,) <$> HD.value HD.int8 <*> HD.value HD.int8)