From c9ef7eda7d64c1f85af7d4385c3ec58bdc23175e Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 8 Nov 2015 21:09:42 +0300 Subject: [PATCH] Complete reimplementation --- CHANGELOG.md | 36 - README.md | 123 ---- Setup.hs | 42 ++ demo/Main.hs | 185 ++++-- doctest/Main.hs | 66 ++ hasql.cabal | 222 +++---- hspec-postgres/Main.hs | 149 ----- hspec/Main.hs | 53 +- library/Hasql.hs | 387 ----------- library/Hasql/Commands.hs | 33 + library/Hasql/Connection.hs | 129 ++++ library/Hasql/CxRow.hs | 64 -- library/Hasql/Deserialization.hs | 732 +++++++++++++++++++++ library/Hasql/Deserialization/Array.hs | 31 + library/Hasql/Deserialization/Composite.hs | 26 + library/Hasql/Deserialization/Result.hs | 207 ++++++ library/Hasql/Deserialization/Results.hs | 76 +++ library/Hasql/Deserialization/Row.hs | 50 ++ library/Hasql/Deserialization/Value.hs | 22 + library/Hasql/IO.hs | 147 +++++ library/Hasql/PTI.hs | 93 +++ library/Hasql/Prelude.hs | 99 ++- library/Hasql/PreparedStatementRegistry.hs | 46 ++ library/Hasql/QQ.hs | 61 -- library/Hasql/QQ/Parser.hs | 65 -- library/Hasql/Query.hs | 29 + library/Hasql/Serialization.hs | 337 ++++++++++ library/Hasql/Serialization/Array.hs | 31 + library/Hasql/Serialization/Params.hs | 46 ++ library/Hasql/Serialization/Value.hs | 27 + library/Hasql/Settings.hs | 46 ++ library/Hasql/TH.hs | 80 --- 32 files changed, 2508 insertions(+), 1232 deletions(-) delete mode 100644 CHANGELOG.md delete mode 100644 README.md create mode 100644 Setup.hs create mode 100644 doctest/Main.hs delete mode 100644 hspec-postgres/Main.hs delete mode 100644 library/Hasql.hs create mode 100644 library/Hasql/Commands.hs create mode 100644 library/Hasql/Connection.hs delete mode 100644 library/Hasql/CxRow.hs create mode 100644 library/Hasql/Deserialization.hs create mode 100644 library/Hasql/Deserialization/Array.hs create mode 100644 library/Hasql/Deserialization/Composite.hs create mode 100644 library/Hasql/Deserialization/Result.hs create mode 100644 library/Hasql/Deserialization/Results.hs create mode 100644 library/Hasql/Deserialization/Row.hs create mode 100644 library/Hasql/Deserialization/Value.hs create mode 100644 library/Hasql/IO.hs create mode 100644 library/Hasql/PTI.hs create mode 100644 library/Hasql/PreparedStatementRegistry.hs delete mode 100644 library/Hasql/QQ.hs delete mode 100644 library/Hasql/QQ/Parser.hs create mode 100644 library/Hasql/Query.hs create mode 100644 library/Hasql/Serialization.hs create mode 100644 library/Hasql/Serialization/Array.hs create mode 100644 library/Hasql/Serialization/Params.hs create mode 100644 library/Hasql/Serialization/Value.hs create mode 100644 library/Hasql/Settings.hs delete mode 100644 library/Hasql/TH.hs diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 index 8f87057..0000000 --- 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/README.md b/README.md deleted file mode 100644 index 277c690..0000000 --- a/README.md +++ /dev/null @@ -1,123 +0,0 @@ -# Hasql [![Build Status](https://travis-ci.org/nikita-volkov/hasql.svg?branch=master)](https://travis-ci.org/nikita-volkov/hasql) - - -Hasql provides a robust and concise yet powerful API for communication with arbitrary relational databases using SQL. - -Currently the only backend available is for PostgreSQL ([which can yield great performance improvements](https://nikita-volkov.github.io/hasql-benchmarks/) over HDBC or postgresql-simple). - -The code used here file is the [demo found in the repository](https://github.com/nikita-volkov/hasql/blob/master/demo/Main.hs) - -## Openning a connection - -For greater convenience the Hasql has a built-in connection pool. All interactions with the database backend are done within the context of such a pool. - -So we have functions to create a pool and one to release all resources held by the pool: - -```haskell -H.acquirePool - :: Hasql.Backend.Cx c => - Hasql.Backend.CxSettings c -> H.PoolSettings -> IO (H.Pool c) -``` - -and - -```haskell -H.releasePool :: H.Pool c -> IO () -``` - -To create the pool we need to pass the connection settings (which are backend dependent) and the pool settings. The code sample below will open a connection to a PostgreSQL database. - -```haskell -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} - --- 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 -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 -``` - -## Executing a statement - -To execute statements we will use a ```Session```, which is just a wrapper for the ```ReaderT``` monad. -This allow us to use the pool for all our session sub-computations. - -So the ```session``` function, is a wrapper for the ```runReaderT```, and besides a parameter with the pool, -we need to pass a function with the return type in ```H.Session``` monad. And as the return we get -either a ```SessionError``` or the result of our function. - -The function we will use to actually execute the transactions is the ```tx``` -which conveniently enough receives a transaction mode, the transactions we want to execute (along with their session context) -and returns the type ```H.Session c m r```. - -It is **important** to notice that running ```IO``` in ```Tx``` is prohibited. - -let's take a look at the signatures proceding: - -```haskell -H.session - :: H.Pool c -> H.Session c m a -> m (Either (H.SessionError c) a) - -H.tx - :: (Control.Monad.Trans.Control.MonadBaseControl IO m, - Hasql.Backend.CxTx c) => - H.TxMode -> (forall s. H.Tx c s r) -> H.Session c m r -``` - -The following code excerpt shows us how the demo code uses these functions to open a -session and start a transaction to create a new table: - -```haskell --- 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))|] -``` - -## Transactions (isolation levels and transaction modes) - -You have probably noticed that the first parameter of ```tx``` belongs to the type ```TxMode```. -This parameter deserves some consideration, for it will determine the behaviour of our transaction. -Let's take a look at its type definition: - -```haskell -type TxMode = Maybe (TxIsolationLevel, TxWriteMode) - -data TxIsolationLevel = - RepeatableReads | - Serializable | - ReadCommitted | - ReadUncommitted - -type TxWriteMode = Maybe Bool -``` - -So when the ```mode``` is ```Nothing```, no transaction is explicitly estabilished on the server. -In PostgreSQL's case this means all commands be commited immediatly after execution -and their isolation level will be *Read Committed*. - -If we pass the tuple, the first element will be the transaction isolation level, you can read more about -[transaction isolation levels on wikipedia](https://en.wikipedia.org/wiki/Isolation_(database_systems)#Isolation_levels). - -The second element is the write mode, which will be interpreted as: - - * ```Nothing``` indicates a "read" mode. - * ```Just True``` indicates a "write" mode. - * ```Just False``` indicates a "write" mode without committing (can be useful for testing purposes). - diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..c103c01 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,42 @@ +-- The code is mostly ripped from +-- https://github.com/ekmett/lens/blob/697582fb9a980f273dbf8496253c5bbefedd0a8b/Setup.lhs +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity, normal ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "import Prelude" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + diff --git a/demo/Main.hs b/demo/Main.hs index 1ba5660..2202a98 100644 --- a/demo/Main.hs +++ b/demo/Main.hs @@ -1,77 +1,122 @@ --- You can execute this file with 'cabal bench demo'. -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} +module Main where -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 +import BasePrelude hiding (assert, isRight, isLeft) +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Functor.Contravariant +import Data.Default.Class +import Contravariant.Extras +import qualified Hasql.Query as Query; +import qualified Hasql.Serialization as S +import qualified Hasql.Deserialization as D +import qualified Hasql.Connection as Connection -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 +main = + do + connectionEither <- Connection.acquire settings + case connectionEither of + Left e -> print e + Right connection -> do + result <- Connection.executeParametricQuery connection sumParametricQuery (1, 2) + print result + where + settings = + Connection.ParametricSettings "localhost" 5432 "postgres" "" "postgres" + sumParametricQuery = + (,,,) template serializer deserializer True + where + template = + "SELECT $1 + $2" + serializer = + contramap fst (S.value S.int8) <> + contramap snd (S.value S.int8) + deserializer = + D.result (D.singleRow (D.value D.int8)) +-- * Model +------------------------- + + +data Account = + Account { + email :: Text , + password :: ByteString , + firstName :: Text , + lastName :: Text + } + + +-- * Queries +------------------------- + + +updateMenu :: Query.ParametricQuery (Text, Int64) Int64 +updateMenu = + (,,,) template serializer deserializer True + where + template = + "UPDATE menu SET title = $1 WHERE id = $2" + serializer = + contrazip2 (S.value S.text) + (S.value S.int8) + deserializer = + D.result (D.rowsAffected) + +accountByEmail :: Query.ParametricQuery Text (Maybe (Int64, Account)) +accountByEmail = + (,,,) template serializer deserializer True + where + template = + "SELECT id, email, password, first_name, last_name \ + \FROM account WHERE email = $1" + serializer = + S.value S.text + deserializer = + D.result (D.maybeRow (identifiedDeserializer accountDeserializer)) + +insertAccount :: Query.ParametricQuery Account Int64 +insertAccount = + (,,,) template serializer deserializer True + where + template = + "INSERT INTO account (email, password, first_name, last_name) \ + \VALUES ($1, $2, $3, $4) \ + \RETURNING id" + serializer = + accountSerializer + deserializer = + D.result (D.singleRow idDeserializer) + + +-- * Deserializers +------------------------- + + +idDeserializer :: D.Row Int64 +idDeserializer = + D.value D.int8 + +accountDeserializer :: D.Row Account +accountDeserializer = + liftM4 Account (D.value def) (D.value def) (D.value def) (D.value def) + +identifiedDeserializer :: D.Row a -> D.Row ( Int64 , a ) +identifiedDeserializer aDeserializer = + liftM2 (,) idDeserializer aDeserializer + + +-- * Serializers +------------------------- + + +accountSerializer :: S.Params Account +accountSerializer = + contramap (\(Account a b c d) -> (a, b, c, d)) $ + contrazip4 (S.value S.text) + (S.value S.bytea) + (S.value S.text) + (S.value S.text) diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 index 0000000..11e3bd8 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,66 @@ +-- The code is mostly ripped from +-- https://github.com/ekmett/lens/blob/d1d97469f0e93c1d3535308954a060e8a04e37aa/tests/doctests.hsc +import BasePrelude +import System.Directory +import System.FilePath +import Test.DocTest +import Build_doctest (deps) + +main :: IO () +main = do + sources <- getSources + doctest $ dfltParams ++ map ("-package="++) deps ++ sources + where + dfltParams = + [ + "-isrc", + "-idist/build/autogen", + "-optP-include", + "-optPdist/build/autogen/cabal_macros.h", + "-XArrows", + "-XBangPatterns", + "-XConstraintKinds", + "-XDataKinds", + "-XDefaultSignatures", + "-XDeriveDataTypeable", + "-XDeriveFunctor", + "-XDeriveGeneric", + "-XEmptyDataDecls", + "-XFlexibleContexts", + "-XFlexibleInstances", + "-XFunctionalDependencies", + "-XGADTs", + "-XGeneralizedNewtypeDeriving", + "-XImpredicativeTypes", + "-XLambdaCase", + "-XLiberalTypeSynonyms", + "-XMultiParamTypeClasses", + "-XMultiWayIf", + "-XNoImplicitPrelude", + "-XNoMonomorphismRestriction", + "-XOverloadedStrings", + "-XPatternGuards", + "-XParallelListComp", + "-XQuasiQuotes", + "-XRankNTypes", + "-XRecordWildCards", + "-XScopedTypeVariables", + "-XStandaloneDeriving", + "-XTemplateHaskell", + "-XTupleSections", + "-XTypeFamilies", + "-XTypeOperators", + "-hide-all-packages" + ] + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "library" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/hasql.cabal b/hasql.cabal index 1006c73..94e69ed 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -1,53 +1,13 @@ name: hasql version: - 0.7.4 -synopsis: - A minimalistic general high level API for relational databases -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: - . - * . - . - * . - . - * . - . + 1 category: - Database + Hasql, Database, PostgreSQL +synopsis: + A very efficient PostgreSQL driver and a flexible mapping API +description: + This package is the root of the \"hasql\" ecosystem. homepage: https://github.com/nikita-volkov/hasql bug-reports: @@ -63,11 +23,9 @@ license: license-file: LICENSE build-type: - Simple + Custom cabal-version: >=1.10 -extra-source-files: - CHANGELOG.md source-repository head @@ -81,123 +39,127 @@ library hs-source-dirs: library ghc-options: - -funbox-strict-fields default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 other-modules: Hasql.Prelude - Hasql.QQ.Parser - Hasql.CxRow - Hasql.TH - Hasql.QQ + Hasql.PTI + Hasql.IO + Hasql.Settings + Hasql.Commands + Hasql.Deserialization.Array + Hasql.Deserialization.Composite + Hasql.Deserialization.Value + Hasql.Deserialization.Row + Hasql.Deserialization.Result + Hasql.Deserialization.Results + Hasql.Serialization.Array + Hasql.Serialization.Value + Hasql.Serialization.Params + Hasql.PreparedStatementRegistry exposed-modules: - Hasql + Hasql.Query + Hasql.Deserialization + Hasql.Serialization + Hasql.Connection 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.2 && < 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.1.*, + 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 + -- errors: + loch-th == 0.2.*, + placeholders == 0.1.*, + -- general: + base-prelude >= 0.1.19 && < 0.2, + base >= 4.6 && < 5 -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 - - -test-suite hspec-postgres +test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: - hspec-postgres + doctest + main-is: + Main.hs + ghc-options: + -threaded + "-with-rtsopts=-N" + build-depends: + doctest == 0.10.*, + directory == 1.2.*, + filepath >= 1.3 && < 1.5, + base-prelude >= 0.1.19 && < 0.2, + base + 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 + + +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: - -- + -- database: hasql, - hasql-postgres == 0.10.*, - -- - slave-thread == 0.1.*, - -- - hspec == 2.1.*, - -- - text, - -- - monad-control, - either, - mtl-prelude < 3, - base-prelude + -- testing: + hspec >= 2.2.0 && < 2.3, + quickcheck-instances >= 0.3.11 && < 0.4, + QuickCheck >= 2.8.1 && < 2.9, + -- general: + base-prelude >= 0.1.19 && < 0.2 --- 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 - type: - exitcode-stdio-1.0 +executable demo hs-source-dirs: demo main-is: Main.hs ghc-options: - -O2 -threaded "-with-rtsopts=-N" - -funbox-strict-fields + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 build-depends: + data-default-class, + contravariant-extras, + contravariant, hasql, - hasql-postgres == 0.10.*, - transformers >= 0.3 && < 0.5, - base - - + text, + bytestring, + base-prelude diff --git a/hspec-postgres/Main.hs b/hspec-postgres/Main.hs deleted file mode 100644 index d643a06..0000000 --- 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 index e80f3af..9c93f13 100644 --- a/hspec/Main.hs +++ b/hspec/Main.hs @@ -1,51 +1,10 @@ -import BasePrelude +module Main where + +import BasePrelude hiding (assert, isRight, isLeft) import Test.Hspec -import qualified Hasql as H -import qualified Hasql.Backend as HB -import qualified Data.Vector as V +import Test.QuickCheck +import Test.QuickCheck.Instances -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 + error "TODO" diff --git a/library/Hasql.hs b/library/Hasql.hs deleted file mode 100644 index 3eeac82..0000000 --- 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 index 0000000..6bba49a --- /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 index 0000000..0d6c167 --- /dev/null +++ b/library/Hasql/Connection.hs @@ -0,0 +1,129 @@ +module Hasql.Connection +( + Connection, + Settings.Settings(..), + acquire, + release, + executeParametricQuery, + -- * Errors + AcquisitionError(..), + ResultsError(..), + ResultError(..), + RowError(..), +) +where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Query as Query +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.Deserialization.Results as ResultsDeserialization +import qualified Hasql.Deserialization as Deserialization +import qualified Hasql.Serialization.Params as ParamsSerialization +import qualified Hasql.Serialization as Serialization +import qualified Hasql.Settings as Settings +import qualified Hasql.IO as IO + + +-- | +-- A single connection to the database. +data Connection = + Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry + +data ResultsError = + -- | + -- An error on the client-side, + -- with a message generated by the \"libpq\" library. + -- Usually indicates problems with connection. + ClientError !( Maybe ByteString ) | + ResultError !ResultError + deriving ( Show ) + +data ResultError = + -- | + -- 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 !RowError | + -- | + -- An unexpected amount of rows. + UnexpectedAmountOfRows !Int + deriving ( Show ) + +data RowError = + EndOfInput | + UnexpectedNull | + ValueError !Text + deriving ( Show ) + +-- | +-- A connection acquistion error. +data AcquisitionError = + -- | Some errors during connection. + BadConnectionStatus !( Maybe ByteString ) | + -- | The server is running a too old version of Postgres. + UnsupportedVersion !Int + deriving ( Show ) + +-- | +-- Acquire a connection using the provided settings. +acquire :: Settings.Settings -> IO ( Either AcquisitionError Connection ) +acquire settings = + runEitherT $ do + pqConnection <- lift (IO.acquireConnection settings) + lift (IO.checkConnectionStatus pqConnection) >>= traverse (left . BadConnectionStatus) + lift (IO.checkServerVersion pqConnection) >>= traverse (left . UnsupportedVersion) + 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 + +-- | +-- Execute a query, producing either a deserialization failure or a successful result. +executeParametricQuery :: Connection -> Query.ParametricQuery a b -> a -> IO ( Either ResultsError b ) +executeParametricQuery (Connection pqConnection integerDatetimes registry) (template, serializer, deserializer, preparable) params = + fmap (mapLeft coerceResultsError) $ runEitherT $ do + EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceSerializer serializer) preparable params + EitherT $ IO.getResults pqConnection integerDatetimes (coerceDeserializer deserializer) + +-- | +-- WARNING: We need to take special care that the structure of +-- the "ResultsDeserialization.Error" type in the public API is an exact copy of +-- "Error", since we're using coercion. +coerceResultsError :: ResultsDeserialization.Error -> ResultsError +coerceResultsError = + unsafeCoerce + +coerceDeserializer :: Deserialization.Results a -> ResultsDeserialization.Results a +coerceDeserializer = + unsafeCoerce + +coerceSerializer :: Serialization.Params a -> ParamsSerialization.Params a +coerceSerializer = + unsafeCoerce diff --git a/library/Hasql/CxRow.hs b/library/Hasql/CxRow.hs deleted file mode 100644 index d2b070e..0000000 --- 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/Deserialization.hs b/library/Hasql/Deserialization.hs new file mode 100644 index 0000000..a3de489 --- /dev/null +++ b/library/Hasql/Deserialization.hs @@ -0,0 +1,732 @@ +-- | +-- A DSL for creating result deserializers. +module Hasql.Deserialization +( + -- * Results + Results, + result, + -- * Result + Result, + noResult, + rowsAffected, + singleRow, + -- ** Specialized multi-row results + maybeRow, + rowsVector, + rowsList, + -- ** Multi-row traversers + foldlRows, + foldrRows, + generateRows, + -- * 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, + -- * 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.Deserialization.Results as Results +import qualified Hasql.Deserialization.Result as Result +import qualified Hasql.Deserialization.Row as Row +import qualified Hasql.Deserialization.Value as Value +import qualified Hasql.Deserialization.Array as Array +import qualified Hasql.Deserialization.Composite as Composite +import qualified Hasql.Prelude as Prelude + + +-- * Results +------------------------- + +-- | +-- Deserializer of possibly multiple results of a single query. +-- +-- Multiple results get produced by non-parametric queries with multiple statements. +-- +-- Parametric queries always produce exactly one result, +-- so don't confuse this with a multi-row result. +-- +newtype Results a = + Results (Results.Results a) + deriving (Functor, Applicative, Monad) + +-- | +-- Lift an individual result deserializer to +-- a deserializer of multiple results. +{-# INLINABLE result #-} +result :: Result a -> Results a +result (Result result) = + Results (Results.single result) + +-- ** Instances +------------------------- + +-- | Maps to @(result 'noResult')@. +instance Default (Results ()) where + {-# INLINE def #-} + def = + result noResult + +-- | Maps to @(result 'rowsAffected')@. +instance Default (Results Int64) where + {-# INLINE def #-} + def = + result rowsAffected + +-- | Maps to @(result ('maybeRow' def))@. +instance Default (Row a) => Default (Results (Maybe a)) where + {-# INLINE def #-} + def = + result (maybeRow def) + +-- | Maps to @(result ('rowsVector' def))@. +instance Default (Row a) => Default (Results (Vector a)) where + {-# INLINE def #-} + def = + result (rowsVector def) + +-- | Maps to @(result ('rowsList' def))@. +instance Default (Row a) => Default (Results ([] a)) where + {-# INLINE def #-} + def = + result (rowsList def) + +-- | Maps to @(result (fmap Identity ('singleRow' def)))@. +instance Default (Row a) => Default (Results (Identity a)) where + {-# INLINE def #-} + def = + result (fmap Identity (singleRow def)) + + +-- * Result +------------------------- + +-- | +-- Deserializer of an individual result. +-- +newtype Result a = + Result (Result.Result a) + deriving (Functor) + +-- | +-- Deserialize no value from the result. +-- +-- Useful for statements like @INSERT@ or @CREATE@. +-- +{-# INLINABLE noResult #-} +noResult :: Result () +noResult = + Result Result.unit + +-- | +-- Get the amount of rows affected by such statements as +-- @UPDATE@ or @DELETE@. +-- +{-# INLINABLE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + Result Result.rowsAffected + +-- | +-- Exactly one row. +-- Will raise the 'Hasql.Connection.UnexpectedAmountOfRows' error if it's any other. +-- +{-# INLINABLE singleRow #-} +singleRow :: Row a -> Result a +singleRow (Row row) = + Result (Result.single row) + +-- ** Multi-row traversers +------------------------- + +-- | +-- Given a function like 'Vector.generateM' packs multiple results accordingly. +-- +{-# INLINABLE generateRows #-} +generateRows :: (forall m. Monad m => Int -> (Int -> m a) -> m b) -> Row a -> Result b +generateRows generateM (Row row) = + Result (Result.generate generateM row) + +-- | +-- Foldl multiple rows. +-- +{-# INLINABLE foldlRows #-} +foldlRows :: (a -> b -> a) -> a -> Row b -> Result a +foldlRows step init (Row row) = + Result (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 (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 (Result.maybe row) + +-- | +-- Zero or more rows packed into the vector. +-- +{-# INLINABLE rowsVector #-} +rowsVector :: Row a -> Result (Vector a) +rowsVector (Row row) = + Result (Result.generate Vector.generateM row) + +-- | +-- Zero or more rows packed into the list. +-- +{-# INLINABLE rowsList #-} +rowsList :: Row a -> Result [ a ] +rowsList (Row row) = + Result (Result.foldr (:) [] row) + + +-- ** Instances +------------------------- + +-- | Maps to 'noResult'. +instance Default (Result ()) where + {-# INLINE def #-} + def = + noResult + +-- | 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 +------------------------- + +-- | +-- Deserializer of an individual row, +-- which gets composed of column value deserializers. +-- +-- 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 deserializer to a composable row deserializer. +-- +{-# INLINABLE value #-} +value :: Value a -> Row a +value (Value imp) = + Row (Row.nonNullValue imp) + +-- | +-- Lift an individual nullable value deserializer to a composable row deserializer. +-- +{-# 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 +------------------------- + +-- | +-- Deserializer of an individual value. +-- +newtype Value a = + Value (Value.Value a) + deriving (Functor) + + +-- ** Plain value deserializers +------------------------- + +-- | +-- Deserializer of the @BOOL@ values. +-- +{-# INLINABLE bool #-} +bool :: Value Bool +bool = + Value (Value.decoder (const Decoder.bool)) + +-- | +-- Deserializer of the @INT2@ values. +-- +{-# INLINABLE int2 #-} +int2 :: Value Int16 +int2 = + Value (Value.decoder (const Decoder.int)) + +-- | +-- Deserializer of the @INT4@ values. +-- +{-# INLINABLE int4 #-} +int4 :: Value Int32 +int4 = + Value (Value.decoder (const Decoder.int)) + +-- | +-- Deserializer of the @INT8@ values. +-- +{-# INLINABLE int8 #-} +int8 :: Value Int64 +int8 = + Value (Value.decoder (const Decoder.int)) + +-- | +-- Deserializer of the @FLOAT4@ values. +-- +{-# INLINABLE float4 #-} +float4 :: Value Float +float4 = + Value (Value.decoder (const Decoder.float4)) + +-- | +-- Deserializer of the @FLOAT8@ values. +-- +{-# INLINABLE float8 #-} +float8 :: Value Double +float8 = + Value (Value.decoder (const Decoder.float8)) + +-- | +-- Deserializer of the @NUMERIC@ values. +-- +{-# INLINABLE numeric #-} +numeric :: Value Scientific +numeric = + Value (Value.decoder (const Decoder.numeric)) + +-- | +-- Deserializer of the @CHAR@ values. +-- Note that it supports UTF-8 values. +{-# INLINABLE char #-} +char :: Value Char +char = + Value (Value.decoder (const Decoder.char)) + +-- | +-- Deserializer of the @TEXT@ values. +-- +{-# INLINABLE text #-} +text :: Value Text +text = + Value (Value.decoder (const Decoder.text_strict)) + +-- | +-- Deserializer of the @BYTEA@ values. +-- +{-# INLINABLE bytea #-} +bytea :: Value ByteString +bytea = + Value (Value.decoder (const Decoder.bytea_strict)) + +-- | +-- Deserializer of the @DATE@ values. +-- +{-# INLINABLE date #-} +date :: Value Day +date = + Value (Value.decoder (const Decoder.date)) + +-- | +-- Deserializer of the @TIMESTAMP@ values. +-- +{-# INLINABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = + Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int)) + +-- | +-- Deserializer 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)) + +-- | +-- Deserializer of the @TIME@ values. +-- +{-# INLINABLE time #-} +time :: Value TimeOfDay +time = + Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int)) + +-- | +-- Deserializer 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)) + +-- | +-- Deserializer of the @INTERVAL@ values. +-- +{-# INLINABLE interval #-} +interval :: Value DiffTime +interval = + Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int)) + +-- | +-- Deserializer of the @UUID@ values. +-- +{-# INLINABLE uuid #-} +uuid :: Value UUID +uuid = + Value (Value.decoder (const Decoder.uuid)) + +-- | +-- Deserializer of the @JSON@ values. +-- +{-# INLINABLE json #-} +json :: Value Aeson.Value +json = + Value (Value.decoder (const Decoder.json)) + + +-- ** Composite value deserializers +------------------------- + +-- | +-- Lifts the 'Array' deserializer to the 'Value' deserializer. +-- +{-# INLINABLE array #-} +array :: Array a -> Value a +array (Array imp) = + Value (Value.decoder (Array.run imp)) + +-- | +-- Lifts the 'Composite' deserializer to the 'Value' deserializer. +-- +{-# INLINABLE composite #-} +composite :: Composite a -> Value a +composite (Composite imp) = + Value (Value.decoder (Composite.run imp)) + +-- | +-- A generic deserializer 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))) + + +-- ** 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 deserializers +------------------------- + +-- | +-- A generic array deserializer. +-- +-- Here's how you can use it to produce a specific array value deserializer: +-- +-- @ +-- 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 deserializer 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' deserializer into an 'Array' deserializer 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' deserializer into an 'Array' deserializer for parsing of nullable leaf values. +{-# INLINABLE arrayNullableValue #-} +arrayNullableValue :: Value a -> Array (Maybe a) +arrayNullableValue (Value imp) = + Array (Array.value (Value.run imp)) + + +-- * Composite deserializers +------------------------- + +-- | +-- Composable deserializer of composite values (rows, records). +newtype Composite a = + Composite (Composite.Composite a) + deriving (Functor, Applicative, Monad) + +-- | +-- Lift a 'Value' deserializer into an 'Composite' deserializer 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' deserializer into an 'Composite' deserializer 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/Deserialization/Array.hs b/library/Hasql/Deserialization/Array.hs new file mode 100644 index 0000000..40b108f --- /dev/null +++ b/library/Hasql/Deserialization/Array.hs @@ -0,0 +1,31 @@ +module Hasql.Deserialization.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/Deserialization/Composite.hs b/library/Hasql/Deserialization/Composite.hs new file mode 100644 index 0000000..1af29d7 --- /dev/null +++ b/library/Hasql/Deserialization/Composite.hs @@ -0,0 +1,26 @@ +module Hasql.Deserialization.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/Deserialization/Result.hs b/library/Hasql/Deserialization/Result.hs new file mode 100644 index 0000000..aa025d0 --- /dev/null +++ b/library/Hasql/Deserialization/Result.hs @@ -0,0 +1,207 @@ +module Hasql.Deserialization.Result where + +import Hasql.Prelude hiding (maybe, many) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Deserialization.Row as Row +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.ByteString as ByteString +import qualified Hasql.Prelude as Prelude + + +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 ) + +run :: Result a -> ( Bool , LibPQ.Result ) -> IO ( Either Error a ) +run (Result reader) env = + runEitherT (runReaderT reader env) + +unit :: Result () +unit = + checkExecStatus $ \case + LibPQ.CommandOk -> True + LibPQ.TuplesOk -> True + _ -> False + +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 + +checkExecStatus :: ( LibPQ.ExecStatus -> Bool ) -> Result () +checkExecStatus predicate = + 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) + +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 + +maybe :: Row.Row a -> Result ( Maybe a ) +maybe rowDes = + 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 rowDes (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +single :: Row.Row a -> Result a +single rowDes = + 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 rowDes (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +generate :: ( forall m. Monad m => Int -> ( Int -> m a ) -> m b ) -> Row.Row a -> Result b +generate generateM rowDes = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + runEitherT $ generateM (rowToInt maxRows) $ \row -> + EitherT $ fmap (mapLeft (RowError row)) $ + Row.run rowDes (result, intToRow row, maxCols, integerDatetimes) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +foldl :: ( a -> b -> a ) -> a -> Row.Row b -> Result a +foldl step init rowDes = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> do + maxRows <- lift $ LibPQ.ntuples result + maxCols <- lift $ LibPQ.nfields result + ref <- lift $ newIORef init + forM_ [0 .. pred (rowToInt maxRows)] $ \rowIndex -> do + row <- + EitherT $ fmap (mapLeft (RowError rowIndex)) $ + Row.run rowDes (result, intToRow rowIndex, maxCols, integerDatetimes) + lift $ modifyIORef ref (\acc -> step acc row) + lift $ readIORef ref + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +foldr :: ( b -> a -> a ) -> a -> Row.Row b -> Result a +foldr step init rowDes = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> do + maxRows <- lift $ LibPQ.ntuples result + maxCols <- lift $ LibPQ.nfields result + ref <- lift $ newIORef init + forM_ (enumToZero (rowToInt maxRows)) $ \rowIndex -> do + row <- + EitherT $ fmap (mapLeft (RowError rowIndex)) $ + Row.run rowDes (result, intToRow rowIndex, maxCols, integerDatetimes) + lift $ modifyIORef ref (\acc -> step row acc) + lift $ readIORef ref + where + enumToZero n = + iterate pred (pred n) & take n + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + diff --git a/library/Hasql/Deserialization/Results.hs b/library/Hasql/Deserialization/Results.hs new file mode 100644 index 0000000..ded61e8 --- /dev/null +++ b/library/Hasql/Deserialization/Results.hs @@ -0,0 +1,76 @@ +-- | +-- 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.Deserialization.Results where + +import Hasql.Prelude hiding (maybe, many) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Prelude as Prelude +import qualified Hasql.Deserialization.Result as Result +import qualified Hasql.Deserialization.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) + +clientError :: Results a +clientError = + Results $ ReaderT $ \(_, connection) -> EitherT $ + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Parse a single result. +{-# INLINABLE single #-} +single :: Result.Result a -> Results a +single resultDes = + Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> + fmap (mapLeft ResultError) (Result.run resultDes (integerDatetimes, result)) + Nothing -> + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINABLE 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. +{-# INLINABLE getResultMaybe #-} +getResultMaybe :: Results ( Maybe LibPQ.Result ) +getResultMaybe = + Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection + +cancel :: Results () +cancel = + undefined diff --git a/library/Hasql/Deserialization/Row.hs b/library/Hasql/Deserialization/Row.hs new file mode 100644 index 0000000..89cef00 --- /dev/null +++ b/library/Hasql/Deserialization/Row.hs @@ -0,0 +1,50 @@ +module Hasql.Deserialization.Row where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified Hasql.Deserialization.Value as Value + + +newtype Row a = + Row + (EitherT Error + (ReaderT + (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) + (StateT LibPQ.Column IO)) + a) + deriving (Functor, Applicative, Monad) + +data Error = + EndOfInput | + UnexpectedNull | + ValueError !Text + deriving (Show) + + +run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a) +run (Row m) env = + flip evalStateT 0 (flip runReaderT env (runEitherT m)) + + +error :: Error -> Row a +error x = + Row (EitherT (return (Left x))) + +-- | +-- Next value, decoded using the provided value deserializer. +value :: Value.Value a -> Row (Maybe a) +value valueDes = + Row $ EitherT $ ReaderT $ \(result, row, maxCol, integerDatetimes) -> StateT $ \col -> + if col < maxCol + then + flip fmap (LibPQ.getvalue result row col) $ \x -> + (traverse (mapLeft ValueError . Decoder.run (Value.run valueDes integerDatetimes)) x, + succ col) + else return (Left EndOfInput, col) + +-- | +-- Next value, decoded using the provided value deserializer. +nonNullValue :: Value.Value a -> Row a +nonNullValue valueDes = + value valueDes >>= maybe (error UnexpectedNull) pure diff --git a/library/Hasql/Deserialization/Value.hs b/library/Hasql/Deserialization/Value.hs new file mode 100644 index 0000000..31b845a --- /dev/null +++ b/library/Hasql/Deserialization/Value.hs @@ -0,0 +1,22 @@ +module Hasql.Deserialization.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 = + Value . ReaderT + diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs new file mode 100644 index 0000000..6d78fbe --- /dev/null +++ b/library/Hasql/IO.hs @@ -0,0 +1,147 @@ +-- | +-- 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.Deserialization.Result as ResultDeserialization +import qualified Hasql.Deserialization.Results as ResultsDeserialization +import qualified Hasql.Serialization.Params as ParamsSerialization +import qualified Hasql.Settings as Settings +import qualified Data.DList as DList + + +{-# INLINE acquireConnection #-} +acquireConnection :: Settings.Settings -> IO LibPQ.Connection +acquireConnection settings = + LibPQ.connectdb (Settings.asBytes settings) + +{-# INLINE acquirePreparedStatementRegistry #-} +acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry +acquirePreparedStatementRegistry = + PreparedStatementRegistry.new + +{-# INLINE releaseConnection #-} +releaseConnection :: LibPQ.Connection -> IO () +releaseConnection connection = + LibPQ.finish connection + +{-# INLINABLE 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 + +{-# INLINABLE initConnection #-} +initConnection :: LibPQ.Connection -> IO () +initConnection c = + void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodingToUTF8 <> Commands.setMinClientMessagesToWarning)) + +{-# INLINE getResults #-} +getResults :: LibPQ.Connection -> Bool -> ResultsDeserialization.Results a -> IO ( Either ResultsDeserialization.Error a ) +getResults connection integerDatetimes des = + do + result <- ResultsDeserialization.run des (integerDatetimes, connection) + fix $ \loop -> LibPQ.getResult connection >>= maybe (pure ()) (const loop) + pure result + +{-# INLINABLE getPreparedStatementKey #-} +getPreparedStatementKey :: + LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> [ LibPQ.Oid ] -> + IO ( Either ResultsDeserialization.Error ByteString ) +getPreparedStatementKey connection registry template oidList = + 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 resultsDeserializer = + if sent + then ResultsDeserialization.single ResultDeserialization.unit + else ResultsDeserialization.clientError + runEitherT $ do + EitherT $ getResults connection undefined resultsDeserializer + pure key + where + wordOIDList = + map (\(LibPQ.Oid x) -> fromIntegral x) oidList + +{-# INLINABLE checkedSend #-} +checkedSend :: LibPQ.Connection -> IO Bool -> IO ( Either ResultsDeserialization.Error () ) +checkedSend connection send = + send >>= \case + False -> fmap (Left . ResultsDeserialization.ClientError) $ LibPQ.errorMessage connection + True -> pure (Right ()) + +{-# INLINABLE sendPreparedParametricQuery #-} +sendPreparedParametricQuery :: + LibPQ.Connection -> + PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> + [ LibPQ.Oid ] -> + [ Maybe ( ByteString , LibPQ.Format ) ] -> + IO ( Either ResultsDeserialization.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 + +{-# INLINABLE sendUnpreparedParametricQuery #-} +sendUnpreparedParametricQuery :: + LibPQ.Connection -> + ByteString -> + [ Maybe ( LibPQ.Oid , ByteString , LibPQ.Format ) ] -> + IO ( Either ResultsDeserialization.Error () ) +sendUnpreparedParametricQuery connection template paramList = + checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary + +{-# INLINABLE sendParametricQuery #-} +sendParametricQuery :: + LibPQ.Connection -> + Bool -> + PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> + ParamsSerialization.Params a -> + Bool -> + a -> + IO ( Either ResultsDeserialization.Error () ) +sendParametricQuery connection integerDatetimes registry template serializer prepared params = + if prepared + then + let + (oidList, valueAndFormatList) = + ParamsSerialization.run' serializer params integerDatetimes + in + sendPreparedParametricQuery connection registry template oidList valueAndFormatList + else + let + paramList = + ParamsSerialization.run'' serializer params integerDatetimes + in + sendUnpreparedParametricQuery connection template paramList diff --git a/library/Hasql/PTI.hs b/library/Hasql/PTI.hs new file mode 100644 index 0000000..61cb0a9 --- /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 index 1d74ac9..0b07845 100644 --- a/library/Hasql/Prelude.hs +++ b/library/Hasql/Prelude.hs @@ -1,53 +1,112 @@ module Hasql.Prelude ( module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + bug, + bottom, ) 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) - --- mmorph -------------------------- -import Control.Monad.Morph as Exports +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible 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" |] diff --git a/library/Hasql/PreparedStatementRegistry.hs b/library/Hasql/PreparedStatementRegistry.hs new file mode 100644 index 0000000..2ee1d20 --- /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 index 7ec9a9c..0000000 --- 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 index 12e8f03..0000000 --- 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 index 0000000..68f2c4f --- /dev/null +++ b/library/Hasql/Query.hs @@ -0,0 +1,29 @@ +module Hasql.Query +( + ParametricQuery(..), + NonparametricQuery(..), +) +where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Deserialization as Deserialization +import qualified Hasql.Serialization as Serialization + + +-- | +-- A strictly single-statement query, which can be parameterized and prepared. +-- +-- SQL template, params serializer, results deserializer and a flag, determining whether it should be prepared. +-- +type ParametricQuery a b = + (ByteString, Serialization.Params a, Deserialization.Results b, Bool) + +-- | +-- A non-parameterizable and non-preparable query, +-- which however can contain multiple statements. +-- +-- SQL, results deserializer. +-- +type NonparametricQuery a = + (ByteString, Deserialization.Results a) diff --git a/library/Hasql/Serialization.hs b/library/Hasql/Serialization.hs new file mode 100644 index 0000000..f89f42f --- /dev/null +++ b/library/Hasql/Serialization.hs @@ -0,0 +1,337 @@ +module Hasql.Serialization +( + -- * Params + Params, + value, + nullableValue, + -- * Value + Value, + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + text, + bytea, + date, + timestamp, + timestamptz, + time, + timetz, + interval, + uuid, + json, + array, + -- * 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.Serialization.Params as Params +import qualified Hasql.Serialization.Value as Value +import qualified Hasql.Serialization.Array as Array +import qualified Hasql.PTI as PTI +import qualified Hasql.Prelude as Prelude + + +-- * Parameters Product Serializer +------------------------- + +-- | +-- Serializer of some representation of a parameters product. +-- +-- Has instances of 'Contravariant', 'Divisible' and 'Monoid', +-- which you can use to compose multiple parameters together. +-- E.g., +-- +-- >someParamsSerializer :: Params (Int64, Maybe Text) +-- >someParamsSerializer = +-- > contramap fst (value int8) <> +-- > contramap snd (nullableValue text) +-- +newtype Params a = + Params (Params.Params a) + deriving (Contravariant, Divisible, Monoid) + +-- | +-- Lift an individual value serializer to a parameters serializer. +-- +{-# INLINABLE value #-} +value :: Value a -> Params a +value (Value x) = + Params (Params.value x) + +-- | +-- Lift an individual nullable value serializer to a parameters serializer. +-- +{-# INLINABLE nullableValue #-} +nullableValue :: Value a -> Params (Maybe a) +nullableValue (Value x) = + Params (Params.nullableValue x) + + +-- ** Instances +------------------------- + +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 = + contramap fst (value def) <> + contramap snd (value def) + + +-- * Value Serializer +------------------------- + +-- | +-- An individual value serializer. +-- Will be mapped to a single placeholder in the query. +-- +newtype Value a = + Value (Value.Value a) + deriving (Contravariant) + +{-# INLINABLE bool #-} +bool :: Value Bool +bool = + Value (Value.unsafePTI PTI.bool (const Encoder.bool)) + +{-# INLINABLE int2 #-} +int2 :: Value Int16 +int2 = + Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16)) + +{-# INLINABLE int4 #-} +int4 :: Value Int32 +int4 = + Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32)) + +{-# INLINABLE int8 #-} +int8 :: Value Int64 +int8 = + Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64)) + +{-# INLINABLE float4 #-} +float4 :: Value Float +float4 = + Value (Value.unsafePTI PTI.float4 (const Encoder.float4)) + +{-# INLINABLE float8 #-} +float8 :: Value Double +float8 = + Value (Value.unsafePTI PTI.float8 (const Encoder.float8)) + +{-# INLINABLE numeric #-} +numeric :: Value Scientific +numeric = + Value (Value.unsafePTI PTI.numeric (const Encoder.numeric)) + +{-# INLINABLE char #-} +char :: Value Char +char = + Value (Value.unsafePTI PTI.char (const Encoder.char)) + +{-# INLINABLE text #-} +text :: Value Text +text = + Value (Value.unsafePTI PTI.text (const Encoder.text_strict)) + +{-# INLINABLE bytea #-} +bytea :: Value ByteString +bytea = + Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict)) + +{-# INLINABLE date #-} +date :: Value Day +date = + Value (Value.unsafePTI PTI.date (const Encoder.date)) + +{-# INLINABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = + Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float)) + +{-# INLINABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = + Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float)) + +{-# INLINABLE time #-} +time :: Value TimeOfDay +time = + Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float)) + +{-# INLINABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = + Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float)) + +{-# INLINABLE interval #-} +interval :: Value DiffTime +interval = + Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float)) + +{-# INLINABLE uuid #-} +uuid :: Value UUID +uuid = + Value (Value.unsafePTI PTI.uuid (const Encoder.uuid)) + +{-# INLINABLE json #-} +json :: Value Aeson.Value +json = + Value (Value.unsafePTI PTI.json (const Encoder.json)) + +{-# INLINABLE array #-} +array :: Array a -> Value a +array (Array imp) = + Array.run imp & \(arrayOID, encoder') -> + Value (Value.Value arrayOID arrayOID encoder') + + +-- ** 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 +------------------------- + +newtype Array a = + Array (Array.Array a) + +{-# INLINABLE arrayValue #-} +arrayValue :: Value a -> Array a +arrayValue (Value (Value.Value elementOID arrayOID encoder')) = + Array (Array.value elementOID arrayOID encoder') + +{-# INLINABLE arrayNullableValue #-} +arrayNullableValue :: Value a -> Array (Maybe a) +arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) = + Array (Array.nullableValue elementOID arrayOID encoder') + +{-# 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/Serialization/Array.hs b/library/Hasql/Serialization/Array.hs new file mode 100644 index 0000000..13641bc --- /dev/null +++ b/library/Hasql/Serialization/Array.hs @@ -0,0 +1,31 @@ +module Hasql.Serialization.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/Serialization/Params.hs b/library/Hasql/Serialization/Params.hs new file mode 100644 index 0000000..98be0f3 --- /dev/null +++ b/library/Hasql/Serialization/Params.hs @@ -0,0 +1,46 @@ +module Hasql.Serialization.Params where + +import Hasql.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.Serialization.Value as Value +import qualified Hasql.PTI as PTI + + +-- | +-- Serializer 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 = + op params + +run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)]) +run' (Params (Op op)) params integerDatetimes = + 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 = + 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/Serialization/Value.hs b/library/Hasql/Serialization/Value.hs new file mode 100644 index 0000000..bd73dda --- /dev/null +++ b/library/Hasql/Serialization/Value.hs @@ -0,0 +1,27 @@ +module Hasql.Serialization.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/Settings.hs b/library/Hasql/Settings.hs new file mode 100644 index 0000000..4daf934 --- /dev/null +++ b/library/Hasql/Settings.hs @@ -0,0 +1,46 @@ +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 + + +-- | +-- Connection settings. +data Settings = + -- | + -- A host, a port, a user, a password and a database. + ParametricSettings ByteString Word16 ByteString ByteString ByteString | + -- | + -- All settings encoded in a single byte string according to + -- . + RawSettings ByteString + deriving (Show) + +{-# INLINE asBytes #-} +asBytes :: Settings -> ByteString +asBytes = + \case + ParametricSettings 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) + ] + RawSettings bytes -> + bytes + diff --git a/library/Hasql/TH.hs b/library/Hasql/TH.hs deleted file mode 100644 index d9a6b61..0000000 --- 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