diff --git a/LICENSE b/LICENSE index dee1a0687a..2b24506473 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,7 @@ Copyright (c) 2014-2026 The PostgREST contributors +Copyright (c) 2014, Nikita Volkov (hasql) +Copyright (c) 2015, Nikita Volkov (hasql-pool, hasql-transaction) +Copyright (c) 2019, Nikita Volkov (hasql-dynamic-statements, hasql-implicits) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -18,3 +21,36 @@ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +--- + +Diogo Biazus (c) 2020 (hasql-notifications) + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/default.nix b/default.nix index 2d05fd1338..549479847b 100644 --- a/default.nix +++ b/default.nix @@ -33,7 +33,7 @@ let src = pkgs.lib.sourceFilesBySuffices (pkgs.gitignoreSource ./.) - [ ".cabal" ".hs" ".lhs" "LICENSE" ]; + [ ".cabal" ".hs" ".hsc" ".lhs" "LICENSE" ]; allOverlays = import nix/overlays; diff --git a/postgrest.cabal b/postgrest.cabal index c0697a41ff..f41d9888c7 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -37,6 +37,135 @@ flag hpc manual: True description: Enable HPC (dev only) +library hasql + default-language: Haskell2010 + default-extensions: ApplicativeDo + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + NoMonomorphismRestriction + NumericUnderscores + OverloadedStrings + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + hs-source-dirs: src/hasql + exposed-modules: Hasql.Connection + Hasql.Connection.Setting + Hasql.Connection.Setting.Connection + Hasql.Connection.Setting.Connection.Param + Hasql.Decoders + Hasql.DynamicStatements.Session + Hasql.DynamicStatements.Snippet + Hasql.DynamicStatements.Statement + Hasql.Encoders + Hasql.Implicits.Encoders + Hasql.Notifications + Hasql.Pipeline + Hasql.Pool + Hasql.Pool.Config + Hasql.Pool.Config.Defaults + Hasql.Pool.Observation + Hasql.Session + Hasql.Statement + Hasql.Transaction + Hasql.Transaction.Sessions + other-modules: Hasql.Commands + Hasql.Connection.Config + Hasql.Connection.Config.ConnectionString + Hasql.Connection.Config.ConnectionString.Params + Hasql.Connection.Core + Hasql.Decoders.All + Hasql.Decoders.Array + Hasql.Decoders.Composite + Hasql.Decoders.Result + Hasql.Decoders.Results + Hasql.Decoders.Row + Hasql.Decoders.Value + Hasql.DynamicStatements.Prelude + Hasql.DynamicStatements.Snippet.Defs + Hasql.Encoders.All + Hasql.Encoders.Array + Hasql.Encoders.Params + Hasql.Encoders.Value + Hasql.Errors + Hasql.IO + Hasql.Implicits.Prelude + Hasql.LibPq14 + Hasql.LibPq14.Ffi + Hasql.LibPq14.Mappings + Hasql.Pipeline.Core + Hasql.Pool.Config.Config + Hasql.Pool.Config.Setting + Hasql.Pool.Prelude + Hasql.Pool.SessionErrorDestructors + Hasql.PostgresTypeInfo + Hasql.Prelude + Hasql.PreparedStatementRegistry + Hasql.Session.Core + Hasql.Transaction.Config + Hasql.Transaction.Private.Prelude + Hasql.Transaction.Private.SQL + Hasql.Transaction.Private.Sessions + Hasql.Transaction.Private.Statements + Hasql.Transaction.Private.Transaction + build-depends: aeson >= 2 && < 3 + , attoparsec >= 0.10 && < 0.15 + , base >= 4.14 && < 5 + , bytestring >= 0.10.8.2 && < 0.13 + , bytestring-strict-builder >= 0.4.5.1 && < 0.5 + , bytestring-tree-builder >= 0.2.7.8 && < 0.3 + , containers >= 0.6 && < 0.8 + , contravariant >= 1.3 && < 2 + , dlist >= 0.8 && < 0.9 || >= 1 && < 2 + , hashable >= 1.2 && < 2 + , hashtables >= 1.1 && < 2 + , iproute >= 1.7 && < 1.8 + , mtl >= 2.2 && < 3 + , postgresql-binary >= 0.14.2 && < 0.15 + , postgresql-libpq >= 0.10.1 && < 0.12 + , profunctors >= 5.1 && < 6 + , ptr >= 0.16.7.2 && < 0.17 + , scientific >= 0.3 && < 0.4 + , stm >= 2.5 && < 3 + , text >= 2 && < 3 + , text-builder >= 1 && < 1.1 + , time >= 1.9 && < 2 + , transformers >= 0.6 && < 0.7 + , uuid >= 1.3 && < 2 + , vector >= 0.10 && < 0.14 + , witherable >= 0.5 && < 0.6 + library default-language: Haskell2010 default-extensions: OverloadedStrings @@ -121,11 +250,7 @@ library , extra >= 1.7.0 && < 2.0 , fast-logger >= 3.2.0 && < 3.3 , fuzzyset >= 0.2.4 && < 0.3 - , hasql >= 1.9 && <= 1.9.3.1 - , hasql-dynamic-statements >= 0.3.1 && <= 0.3.1.8 - , hasql-notifications >= 0.2.4.0 && < 0.3 - , hasql-pool >= 1.1 && <= 1.3.0.4 - , hasql-transaction >= 1.0.1 && <= 1.2.1 + , postgrest:hasql , http-client >= 0.7.19 && < 0.8 , http-types >= 0.12.2 && < 0.13 , insert-ordered-containers >= 0.2.2 && < 0.3 @@ -284,8 +409,7 @@ test-suite spec , bytestring >= 0.10.8 && < 0.13 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5.7 && < 0.8 - , hasql-pool >= 1.0.1 && <= 1.3.0.4 - , hasql-transaction >= 1.0.1 && <= 1.2.1 + , postgrest:hasql , heredoc >= 0.2 && < 0.3 , hspec >= 2.3 && < 2.12 , hspec-expectations >= 0.8.4 && < 0.9 @@ -330,8 +454,7 @@ test-suite observability build-depends: base >= 4.9 && < 4.22 , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.13 - , hasql-pool >= 1.0.1 && <= 1.3.0.4 - , hasql-transaction >= 1.0.1 && <= 1.2.1 + , postgrest:hasql , hspec >= 2.3 && < 2.12 , hspec-expectations >= 0.8.4 && < 0.9 , hspec-wai >= 0.10 && < 0.12 diff --git a/src/hasql/Hasql/Commands.hs b/src/hasql/Hasql/Commands.hs new file mode 100644 index 0000000000..6f5f407895 --- /dev/null +++ b/src/hasql/Hasql/Commands.hs @@ -0,0 +1,27 @@ +module Hasql.Commands + ( Commands, + asBytes, + setEncodersToUTF8, + setMinClientMessagesToWarning, + ) +where + +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import Hasql.Prelude + +newtype Commands + = Commands (DList BB.Builder) + deriving (Semigroup, Monoid) + +asBytes :: Commands -> ByteString +asBytes (Commands list) = + BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') list + +setEncodersToUTF8 :: Commands +setEncodersToUTF8 = + Commands (pure "SET client_encoding = 'UTF8'") + +setMinClientMessagesToWarning :: Commands +setMinClientMessagesToWarning = + Commands (pure "SET client_min_messages TO WARNING") diff --git a/src/hasql/Hasql/Connection.hs b/src/hasql/Hasql/Connection.hs new file mode 100644 index 0000000000..14c892eb20 --- /dev/null +++ b/src/hasql/Hasql/Connection.hs @@ -0,0 +1,12 @@ +-- | +-- This module provides a low-level effectful API dealing with the connections to the database. +module Hasql.Connection + ( Connection, + ConnectionError, + acquire, + release, + withLibPQConnection, + ) +where + +import Hasql.Connection.Core diff --git a/src/hasql/Hasql/Connection/Config.hs b/src/hasql/Hasql/Connection/Config.hs new file mode 100644 index 0000000000..a406912c29 --- /dev/null +++ b/src/hasql/Hasql/Connection/Config.hs @@ -0,0 +1,29 @@ +module Hasql.Connection.Config where + +import Hasql.Prelude + +data Config = Config + { connectionString :: ByteString, + usePreparedStatements :: Bool + } + +class Updates a where + update :: a -> Config -> Config + +nil :: Config +nil = + Config + { connectionString = "", + usePreparedStatements = True + } + +fromUpdates :: (Updates a) => [a] -> Config +fromUpdates = foldl' (flip update) nil + +setConnectionString :: ByteString -> Config -> Config +setConnectionString connectionString config = + config {connectionString} + +setUsePreparedStatements :: Bool -> Config -> Config +setUsePreparedStatements usePreparedStatements config = + config {usePreparedStatements} diff --git a/src/hasql/Hasql/Connection/Config/ConnectionString.hs b/src/hasql/Hasql/Connection/Config/ConnectionString.hs new file mode 100644 index 0000000000..21e9ce904b --- /dev/null +++ b/src/hasql/Hasql/Connection/Config/ConnectionString.hs @@ -0,0 +1,31 @@ +module Hasql.Connection.Config.ConnectionString where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding +import qualified Hasql.Connection.Config.ConnectionString.Params as Params +import Hasql.Prelude + +type ConnectionString = ByteString + +class Constructs a where + construct :: a -> ConnectionString + +fromText :: Text -> ConnectionString +fromText = Data.Text.Encoding.encodeUtf8 + +fromParams :: Params.Params -> ConnectionString +fromParams = + B.intercalate " " . fmap renderParam . Map.toList + where + renderParam (k, v) = mconcat [k, "=", "'", escapeSingleQuote v, "'"] + + escapeSingleQuote = + BC.concatMap + ( \w -> + case w of + '\'' -> BC.pack "\\'" + '\\' -> BC.pack "\\\\" + _ -> BC.singleton w + ) diff --git a/src/hasql/Hasql/Connection/Config/ConnectionString/Params.hs b/src/hasql/Hasql/Connection/Config/ConnectionString/Params.hs new file mode 100644 index 0000000000..ff267f55e5 --- /dev/null +++ b/src/hasql/Hasql/Connection/Config/ConnectionString/Params.hs @@ -0,0 +1,18 @@ +module Hasql.Connection.Config.ConnectionString.Params where + +import qualified Data.Map.Strict as Map +import Hasql.Prelude + +type Params = Map.Map ByteString ByteString + +class Updates a where + update :: a -> Params -> Params + +nil :: Params +nil = Map.empty + +fromUpdates :: (Updates a) => [a] -> Params +fromUpdates = foldl' (flip update) nil + +setKeyValue :: ByteString -> ByteString -> Params -> Params +setKeyValue = Map.insert diff --git a/src/hasql/Hasql/Connection/Core.hs b/src/hasql/Hasql/Connection/Core.hs new file mode 100644 index 0000000000..cb3718c2d9 --- /dev/null +++ b/src/hasql/Hasql/Connection/Core.hs @@ -0,0 +1,63 @@ +-- | +-- This module provides a low-level effectful API dealing with the connections to the database. +module Hasql.Connection.Core where + +import qualified Hasql.Connection.Config as Config +import qualified Hasql.Connection.Setting as Setting +import qualified Hasql.IO as IO +import qualified Hasql.LibPq14 as LibPQ +import Hasql.Prelude +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry + +-- | +-- A single connection to the database. +data Connection + = Connection + -- | Whether prepared statements are allowed. + !Bool + -- | Lower level libpq connection. + !(MVar LibPQ.Connection) + -- | Integer datetimes. + !Bool + -- | Prepared statement registry. + !PreparedStatementRegistry.PreparedStatementRegistry + +-- | +-- Possible details of the connection acquistion error. +type ConnectionError = + Maybe ByteString + +-- | +-- Establish a connection according to the provided settings. +acquire :: + [Setting.Setting] -> + IO (Either ConnectionError Connection) +acquire settings = + {-# SCC "acquire" #-} + runExceptT $ do + pqConnection <- lift (IO.acquireConnection (Config.connectionString config)) + lift (IO.checkConnectionStatus pqConnection) >>= traverse_ throwError + lift (IO.initConnection pqConnection) + integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection) + registry <- lift IO.acquirePreparedStatementRegistry + pqConnectionRef <- lift (newMVar pqConnection) + pure (Connection (Config.usePreparedStatements config) pqConnectionRef integerDatetimes registry) + where + config = Config.fromUpdates settings + +-- | +-- Release the connection. +release :: Connection -> IO () +release (Connection _ pqConnectionRef _ _) = + mask_ $ do + nullConnection <- LibPQ.newNullConnection + pqConnection <- swapMVar pqConnectionRef nullConnection + IO.releaseConnection pqConnection + +-- | +-- Execute an operation on the raw @libpq@ 'LibPQ.Connection'. +-- +-- The access to the connection is exclusive. +withLibPQConnection :: Connection -> (LibPQ.Connection -> IO a) -> IO a +withLibPQConnection (Connection _ pqConnectionRef _ _) = + withMVar pqConnectionRef diff --git a/src/hasql/Hasql/Connection/Setting.hs b/src/hasql/Hasql/Connection/Setting.hs new file mode 100644 index 0000000000..bbcbeaefb1 --- /dev/null +++ b/src/hasql/Hasql/Connection/Setting.hs @@ -0,0 +1,35 @@ +module Hasql.Connection.Setting + ( Setting, + connection, + usePreparedStatements, + ) +where + +import qualified Hasql.Connection.Config as Config +import qualified Hasql.Connection.Config.ConnectionString as Config.ConnectionString +import qualified Hasql.Connection.Setting.Connection as Connection +import Hasql.Prelude + +-- | Setting of a client handle. +newtype Setting = Setting (Config.Config -> Config.Config) + +instance Config.Updates Setting where + update (Setting update) = update + +-- | Connection details like address of the remote service and authentication info. +connection :: Connection.Connection -> Setting +connection = + Setting . Config.setConnectionString . Config.ConnectionString.construct + +-- | Whether prepared statements are allowed. +-- +-- When 'False', even the statements marked as preparable will be executed without preparation. +-- +-- This is useful when dealing with proxying applications like @pgbouncer@, which may be incompatible with prepared statements. +-- Consult their docs or just set it to 'False' to stay on the safe side. +-- It should be noted that starting from version @1.21.0@ @pgbouncer@ now does provide support for prepared statements. +-- +-- 'True' by default. +usePreparedStatements :: Bool -> Setting +usePreparedStatements = + Setting . Config.setUsePreparedStatements diff --git a/src/hasql/Hasql/Connection/Setting/Connection.hs b/src/hasql/Hasql/Connection/Setting/Connection.hs new file mode 100644 index 0000000000..c5a419bb23 --- /dev/null +++ b/src/hasql/Hasql/Connection/Setting/Connection.hs @@ -0,0 +1,27 @@ +module Hasql.Connection.Setting.Connection + ( Connection, + string, + params, + ) +where + +import qualified Hasql.Connection.Config.ConnectionString as Config.ConnectionString +import qualified Hasql.Connection.Config.ConnectionString.Params as Config.ConnectionString.Params +import qualified Hasql.Connection.Setting.Connection.Param as Param +import Hasql.Prelude + +-- | Instructions on how to connect to the database. +newtype Connection = Connection ByteString + +instance Config.ConnectionString.Constructs Connection where + construct = coerce + +-- | Preconstructed connection string according to . +string :: Text -> Connection +string = + Connection . Config.ConnectionString.fromText + +-- | Structured parameters. +params :: [Param.Param] -> Connection +params = + Connection . Config.ConnectionString.fromParams . Config.ConnectionString.Params.fromUpdates diff --git a/src/hasql/Hasql/Connection/Setting/Connection/Param.hs b/src/hasql/Hasql/Connection/Setting/Connection/Param.hs new file mode 100644 index 0000000000..1f8f56b5f5 --- /dev/null +++ b/src/hasql/Hasql/Connection/Setting/Connection/Param.hs @@ -0,0 +1,52 @@ +module Hasql.Connection.Setting.Connection.Param + ( Param, + host, + port, + user, + password, + dbname, + other, + ) +where + +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as Text +import qualified Hasql.Connection.Config.ConnectionString.Params as Config +import Hasql.Prelude + +-- | Parameter of the connection instructions. +newtype Param = Param (Config.Params -> Config.Params) + +instance Config.Updates Param where + update = coerce + +-- | Host domain name or IP-address. +host :: Text -> Param +host = + Param . Config.setKeyValue "host" . Text.encodeUtf8 + +-- | Port number. +port :: Word16 -> Param +port = + Param . Config.setKeyValue "port" . BL.toStrict . BB.toLazyByteString . BB.word16Dec + +-- | User name. +user :: Text -> Param +user = + Param . Config.setKeyValue "user" . Text.encodeUtf8 + +-- | Password. +password :: Text -> Param +password = + Param . Config.setKeyValue "password" . Text.encodeUtf8 + +-- | Database name. +dbname :: Text -> Param +dbname = + Param . Config.setKeyValue "dbname" . Text.encodeUtf8 + +-- | Any other parameter under the provided name according to . +other :: Text -> Text -> Param +other name = + Param . Config.setKeyValue (Text.encodeUtf8 name) . Text.encodeUtf8 diff --git a/src/hasql/Hasql/Decoders.hs b/src/hasql/Hasql/Decoders.hs new file mode 100644 index 0000000000..37a6602f35 --- /dev/null +++ b/src/hasql/Hasql/Decoders.hs @@ -0,0 +1,85 @@ +-- | +-- A DSL for declaration of result decoders. +module Hasql.Decoders + ( -- * Result + Result, + noResult, + rowsAffected, + singleRow, + + -- ** Specialized multi-row results + rowMaybe, + rowVector, + rowList, + + -- ** Multi-row traversers + foldlRows, + foldrRows, + + -- * Row + Row, + column, + + -- * Nullability + NullableOrNot, + nonNullable, + nullable, + + -- * Value + Value, + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + text, + bytea, + date, + timestamp, + timestamptz, + time, + timetz, + interval, + uuid, + inet, + macaddr, + json, + jsonBytes, + jsonb, + jsonbBytes, + int4range, + int8range, + numrange, + tsrange, + tstzrange, + daterange, + int4multirange, + int8multirange, + nummultirange, + tsmultirange, + tstzmultirange, + datemultirange, + array, + listArray, + vectorArray, + composite, + hstore, + enum, + custom, + refine, + + -- * Array + Array, + dimension, + element, + + -- * Composite + Composite, + field, + ) +where + +import Hasql.Decoders.All diff --git a/src/hasql/Hasql/Decoders/All.hs b/src/hasql/Hasql/Decoders/All.hs new file mode 100644 index 0000000000..d2809bb94e --- /dev/null +++ b/src/hasql/Hasql/Decoders/All.hs @@ -0,0 +1,491 @@ +-- | +-- A DSL for declaration of result decoders. +module Hasql.Decoders.All where + +import qualified Data.Aeson as Aeson +import qualified Data.IP as Iproute +import qualified Data.Vector.Generic as GenericVector +import qualified Hasql.Decoders.Array as Array +import qualified Hasql.Decoders.Composite as Composite +import qualified Hasql.Decoders.Result as Result +import qualified Hasql.Decoders.Results as Results +import qualified Hasql.Decoders.Row as Row +import qualified Hasql.Decoders.Value as Value +import Hasql.Prelude hiding (bool, maybe) +import qualified Hasql.Prelude as Prelude +import qualified PostgreSQL.Binary.Decoding as A +import qualified PostgreSQL.Binary.Range as R + +-- * Result + +-- | +-- Decoder of a query result. +newtype Result a = Result (Results.Results a) deriving (Functor, Filterable) + +-- | +-- Decode no value from the result. +-- +-- Useful for statements like @INSERT@ or @CREATE@. +{-# INLINEABLE noResult #-} +noResult :: Result () +noResult = Result (Results.single Result.noResult) + +-- | +-- Get the amount of rows affected by such statements as +-- @UPDATE@ or @DELETE@. +{-# INLINEABLE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = Result (Results.single Result.rowsAffected) + +-- | +-- Exactly one row. +-- Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other. +{-# INLINEABLE singleRow #-} +singleRow :: Row a -> Result a +singleRow (Row row) = Result (Results.single (Result.single row)) + +refineResult :: (a -> Either Text b) -> Result a -> Result b +refineResult refiner (Result results) = Result (Results.refine refiner results) + +-- ** Multi-row traversers + +-- | +-- Foldl multiple rows. +{-# INLINEABLE foldlRows #-} +foldlRows :: (a -> b -> a) -> a -> Row b -> Result a +foldlRows step init (Row row) = Result (Results.single (Result.foldl step init row)) + +-- | +-- Foldr multiple rows. +{-# INLINEABLE foldrRows #-} +foldrRows :: (b -> a -> a) -> a -> Row b -> Result a +foldrRows step init (Row row) = Result (Results.single (Result.foldr step init row)) + +-- ** Specialized multi-row results + +-- | +-- Maybe one row or none. +{-# INLINEABLE rowMaybe #-} +rowMaybe :: Row a -> Result (Maybe a) +rowMaybe (Row row) = Result (Results.single (Result.maybe row)) + +-- | +-- Zero or more rows packed into the vector. +-- +-- It's recommended to prefer this function to 'rowList', +-- since it performs notably better. +{-# INLINEABLE rowVector #-} +rowVector :: Row a -> Result (Vector a) +rowVector (Row row) = Result (Results.single (Result.vector row)) + +-- | +-- Zero or more rows packed into the list. +{-# INLINEABLE rowList #-} +rowList :: Row a -> Result [a] +rowList = foldrRows strictCons [] + +-- * Row + +-- | +-- Decoder of an individual row, +-- which gets composed of column value decoders. +-- +-- E.g.: +-- +-- @ +-- x :: 'Row' (Maybe Int64, Text, TimeOfDay) +-- x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') 'time' +-- @ +newtype Row a = Row (Row.Row a) + deriving (Functor, Applicative, Monad, MonadFail) + +-- | +-- Lift an individual value decoder to a composable row decoder. +{-# INLINEABLE column #-} +column :: NullableOrNot Value a -> Row a +column = \case + NonNullable (Value imp) -> Row (Row.nonNullValue imp) + Nullable (Value imp) -> Row (Row.value imp) + +-- * Nullability + +-- | +-- Extensional specification of nullability over a generic decoder. +data NullableOrNot decoder a where + NonNullable :: decoder a -> NullableOrNot decoder a + Nullable :: decoder a -> NullableOrNot decoder (Maybe a) + +-- | +-- Specify that a decoder produces a non-nullable value. +nonNullable :: decoder a -> NullableOrNot decoder a +nonNullable = NonNullable + +-- | +-- Specify that a decoder produces a nullable value. +nullable :: decoder a -> NullableOrNot decoder (Maybe a) +nullable = Nullable + +-- * Value + +-- | +-- Decoder of a value. +newtype Value a = Value (Value.Value a) + deriving (Functor, Filterable) + +type role Value representational + +-- | +-- Decoder of the @BOOL@ values. +{-# INLINEABLE bool #-} +bool :: Value Bool +bool = Value (Value.decoder (const A.bool)) + +-- | +-- Decoder of the @INT2@ values. +{-# INLINEABLE int2 #-} +int2 :: Value Int16 +int2 = Value (Value.decoder (const A.int)) + +-- | +-- Decoder of the @INT4@ values. +{-# INLINEABLE int4 #-} +int4 :: Value Int32 +int4 = Value (Value.decoder (const A.int)) + +-- | +-- Decoder of the @INT8@ values. +{-# INLINEABLE int8 #-} +int8 :: Value Int64 +int8 = + {-# SCC "int8" #-} + Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int))) + +-- | +-- Decoder of the @FLOAT4@ values. +{-# INLINEABLE float4 #-} +float4 :: Value Float +float4 = Value (Value.decoder (const A.float4)) + +-- | +-- Decoder of the @FLOAT8@ values. +{-# INLINEABLE float8 #-} +float8 :: Value Double +float8 = Value (Value.decoder (const A.float8)) + +-- | +-- Decoder of the @NUMERIC@ values. +{-# INLINEABLE numeric #-} +numeric :: Value Scientific +numeric = Value (Value.decoder (const A.numeric)) + +-- | +-- Decoder of the @CHAR@ values. +-- Note that it supports Unicode values. +{-# INLINEABLE char #-} +char :: Value Char +char = Value (Value.decoder (const A.char)) + +-- | +-- Decoder of the @TEXT@ values. +{-# INLINEABLE text #-} +text :: Value Text +text = Value (Value.decoder (const A.text_strict)) + +-- | +-- Decoder of the @BYTEA@ values. +{-# INLINEABLE bytea #-} +bytea :: Value ByteString +bytea = Value (Value.decoder (const A.bytea_strict)) + +-- | +-- Decoder of the @DATE@ values. +{-# INLINEABLE date #-} +date :: Value Day +date = Value (Value.decoder (const A.date)) + +-- | +-- Decoder of the @TIMESTAMP@ values. +{-# INLINEABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int)) + +-- | +-- Decoder of the @TIMESTAMPTZ@ values. +-- +-- /NOTICE/ +-- +-- Postgres does not store the timezone information of @TIMESTAMPTZ@. +-- Instead it stores a UTC value and performs silent conversions +-- to the currently set timezone, when dealt with in the text format. +-- However this library bypasses the silent conversions +-- and communicates with Postgres using the UTC values directly. +{-# INLINEABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int)) + +-- | +-- Decoder of the @TIME@ values. +{-# INLINEABLE time #-} +time :: Value TimeOfDay +time = Value (Value.decoder (Prelude.bool A.time_float A.time_int)) + +-- | +-- Decoder of the @TIMETZ@ values. +-- +-- Unlike in case of @TIMESTAMPTZ@, +-- Postgres does store the timezone information for @TIMETZ@. +-- However the Haskell's \"time\" library does not contain any composite type, +-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' +-- to represent a value on the Haskell's side. +{-# INLINEABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int)) + +-- | +-- Decoder of the @INTERVAL@ values. +{-# INLINEABLE interval #-} +interval :: Value DiffTime +interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int)) + +-- | +-- Decoder of the @UUID@ values. +{-# INLINEABLE uuid #-} +uuid :: Value UUID +uuid = Value (Value.decoder (const A.uuid)) + +-- | +-- Decoder of the @INET@ values. +{-# INLINEABLE inet #-} +inet :: Value Iproute.IPRange +inet = Value (Value.decoder (const A.inet)) + +-- | +-- Decoder of the @MACADDR@ values. +-- +-- Represented as a 6-tuple of Word8 values in big endian order. If +-- you use `ip` library consider using it with `fromOctets`. +-- +-- > (\(a,b,c,d,e,f) -> fromOctets a b c d e f) <$> macaddr +{-# INLINEABLE macaddr #-} +macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) +macaddr = Value (Value.decoder (const A.macaddr)) + +-- | +-- Decoder of the @JSON@ values into a JSON AST. +{-# INLINEABLE json #-} +json :: Value Aeson.Value +json = Value (Value.decoder (const A.json_ast)) + +-- | +-- Decoder of the @JSON@ values into a raw JSON 'ByteString'. +{-# INLINEABLE jsonBytes #-} +jsonBytes :: (ByteString -> Either Text a) -> Value a +jsonBytes fn = Value (Value.decoder (const (A.json_bytes fn))) + +-- | +-- Decoder of the @JSONB@ values into a JSON AST. +{-# INLINEABLE jsonb #-} +jsonb :: Value Aeson.Value +jsonb = Value (Value.decoder (const A.jsonb_ast)) + +-- | +-- Decoder of the @JSONB@ values into a raw JSON 'ByteString'. +{-# INLINEABLE jsonbBytes #-} +jsonbBytes :: (ByteString -> Either Text a) -> Value a +jsonbBytes fn = Value (Value.decoder (const (A.jsonb_bytes fn))) + +-- | +-- Decoder of the @INT4RANGE@ values. +{-# INLINEABLE int4range #-} +int4range :: Value (R.Range Int32) +int4range = Value (Value.decoder (const A.int4range)) + +-- | +-- Decoder of the @INT8RANGE@ values. +{-# INLINEABLE int8range #-} +int8range :: Value (R.Range Int64) +int8range = Value (Value.decoder (const A.int8range)) + +-- | +-- Decoder of the @NUMRANGE@ values. +{-# INLINEABLE numrange #-} +numrange :: Value (R.Range Scientific) +numrange = Value (Value.decoder (const A.numrange)) + +-- | +-- Decoder of the @TSRANGE@ values. +{-# INLINEABLE tsrange #-} +tsrange :: Value (R.Range LocalTime) +tsrange = Value (Value.decoder (Prelude.bool A.tsrange_float A.tsrange_int)) + +-- | +-- Decoder of the @TSTZRANGE@ values. +{-# INLINEABLE tstzrange #-} +tstzrange :: Value (R.Range UTCTime) +tstzrange = Value (Value.decoder (Prelude.bool A.tstzrange_float A.tstzrange_int)) + +-- | +-- Decoder of the @DATERANGE@ values. +{-# INLINEABLE daterange #-} +daterange :: Value (R.Range Day) +daterange = Value (Value.decoder (const A.daterange)) + +-- | +-- Decoder of the @INT4MULTIRANGE@ values. +{-# INLINEABLE int4multirange #-} +int4multirange :: Value (R.Multirange Int32) +int4multirange = Value (Value.decoder (const A.int4multirange)) + +-- | +-- Decoder of the @INT8MULTIRANGE@ values. +{-# INLINEABLE int8multirange #-} +int8multirange :: Value (R.Multirange Int64) +int8multirange = Value (Value.decoder (const A.int8multirange)) + +-- | +-- Decoder of the @NUMMULTIRANGE@ values. +{-# INLINEABLE nummultirange #-} +nummultirange :: Value (R.Multirange Scientific) +nummultirange = Value (Value.decoder (const A.nummultirange)) + +-- | +-- Decoder of the @TSMULTIRANGE@ values. +{-# INLINEABLE tsmultirange #-} +tsmultirange :: Value (R.Multirange LocalTime) +tsmultirange = Value (Value.decoder (Prelude.bool A.tsmultirange_float A.tsmultirange_int)) + +-- | +-- Decoder of the @TSTZMULTIRANGE@ values. +{-# INLINEABLE tstzmultirange #-} +tstzmultirange :: Value (R.Multirange UTCTime) +tstzmultirange = Value (Value.decoder (Prelude.bool A.tstzmultirange_float A.tstzmultirange_int)) + +-- | +-- Decoder of the @DATEMULTIRANGE@ values. +{-# INLINEABLE datemultirange #-} +datemultirange :: Value (R.Multirange Day) +datemultirange = Value (Value.decoder (const A.datemultirange)) + +-- | +-- Lift a custom value decoder function to a 'Value' decoder. +{-# INLINEABLE custom #-} +custom :: (Bool -> ByteString -> Either Text a) -> Value a +custom fn = Value (Value.decoderFn fn) + +-- | +-- Refine a value decoder, lifting the possible error to the session level. +{-# INLINEABLE refine #-} +refine :: (a -> Either Text b) -> Value a -> Value b +refine fn (Value v) = Value (Value.refine fn v) + +-- | +-- A generic decoder of @HSTORE@ values. +-- +-- Here's how you can use it to construct a specific value: +-- +-- @ +-- x :: Value [(Text, Maybe Text)] +-- x = hstore 'replicateM' +-- @ +{-# INLINEABLE hstore #-} +hstore :: (forall m. (Monad m) => Int -> m (Text, Maybe Text) -> m a) -> Value a +hstore replicateM = Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict))) + +-- | +-- Given a partial mapping from text to value, +-- produces a decoder of that value. +enum :: (Text -> Maybe a) -> Value a +enum mapping = Value (Value.decoder (const (A.enum mapping))) + +-- | +-- Lift an 'Array' decoder to a 'Value' decoder. +{-# INLINEABLE array #-} +array :: Array a -> Value a +array (Array imp) = Value (Value.decoder (Array.run imp)) + +-- | +-- Lift a value decoder of element into a unidimensional array decoder producing a list. +-- +-- This function is merely a shortcut to the following expression: +-- +-- @ +-- ('array' . 'dimension' Control.Monad.'replicateM' . 'element') +-- @ +-- +-- Please notice that in case of multidimensional arrays nesting 'listArray' decoder +-- won't work. You have to explicitly construct the array decoder using 'array'. +{-# INLINE listArray #-} +listArray :: NullableOrNot Value element -> Value [element] +listArray = array . dimension replicateM . element + +-- | +-- Lift a value decoder of element into a unidimensional array decoder producing a generic vector. +-- +-- This function is merely a shortcut to the following expression: +-- +-- @ +-- ('array' . 'dimension' Data.Vector.Generic.'GenericVector.replicateM' . 'element') +-- @ +-- +-- Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder +-- won't work. You have to explicitly construct the array decoder using 'array'. +{-# INLINE vectorArray #-} +vectorArray :: (GenericVector.Vector vector element) => NullableOrNot Value element -> Value (vector element) +vectorArray = array . dimension GenericVector.replicateM . element + +-- | +-- Lift a 'Composite' decoder to a 'Value' decoder. +{-# INLINEABLE composite #-} +composite :: Composite a -> Value a +composite (Composite imp) = Value (Value.decoder (Composite.run imp)) + +-- * Array decoders + +-- | +-- A generic array decoder. +-- +-- Here's how you can use it to produce a specific array value decoder: +-- +-- @ +-- x :: 'Value' [[Text]] +-- x = 'array' ('dimension' 'replicateM' ('dimension' 'replicateM' ('element' ('nonNullable' 'text')))) +-- @ +newtype Array a = Array (Array.Array a) + deriving (Functor) + +-- | +-- A function for parsing a dimension of an array. +-- Provides support for multi-dimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines the output value. +-- +-- * A decoder of its components, which can be either another 'dimension' or 'element'. +{-# INLINEABLE dimension #-} +dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b +dimension replicateM (Array imp) = Array (Array.dimension replicateM imp) + +-- | +-- Lift a 'Value' decoder into an 'Array' decoder for parsing of leaf values. +{-# INLINEABLE element #-} +element :: NullableOrNot Value a -> Array a +element = \case + NonNullable (Value imp) -> Array (Array.nonNullValue (Value.run imp)) + Nullable (Value imp) -> Array (Array.value (Value.run imp)) + +-- * Composite decoders + +-- | +-- Composable decoder of composite values (rows, records). +newtype Composite a = Composite (Composite.Composite a) + deriving (Functor, Applicative, Monad, MonadFail) + +-- | +-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values. +field :: NullableOrNot Value a -> Composite a +field = \case + NonNullable (Value imp) -> Composite (Composite.nonNullValue (Value.run imp)) + Nullable (Value imp) -> Composite (Composite.value (Value.run imp)) diff --git a/src/hasql/Hasql/Decoders/Array.hs b/src/hasql/Hasql/Decoders/Array.hs new file mode 100644 index 0000000000..b72aee787e --- /dev/null +++ b/src/hasql/Hasql/Decoders/Array.hs @@ -0,0 +1,28 @@ +module Hasql.Decoders.Array where + +import Hasql.Prelude +import qualified PostgreSQL.Binary.Decoding as A + +newtype Array a + = Array (ReaderT Bool A.Array a) + deriving (Functor) + +{-# INLINE run #-} +run :: Array a -> Bool -> A.Value a +run (Array imp) env = + A.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 -> A.dimensionArray replicateM (runReaderT imp env) + +{-# INLINE value #-} +value :: (Bool -> A.Value a) -> Array (Maybe a) +value decoder' = + Array $ ReaderT $ A.nullableValueArray . decoder' + +{-# INLINE nonNullValue #-} +nonNullValue :: (Bool -> A.Value a) -> Array a +nonNullValue decoder' = + Array $ ReaderT $ A.valueArray . decoder' diff --git a/src/hasql/Hasql/Decoders/Composite.hs b/src/hasql/Hasql/Decoders/Composite.hs new file mode 100644 index 0000000000..56907890ba --- /dev/null +++ b/src/hasql/Hasql/Decoders/Composite.hs @@ -0,0 +1,23 @@ +module Hasql.Decoders.Composite where + +import Hasql.Prelude +import qualified PostgreSQL.Binary.Decoding as A + +newtype Composite a + = Composite (ReaderT Bool A.Composite a) + deriving (Functor, Applicative, Monad, MonadFail) + +{-# INLINE run #-} +run :: Composite a -> Bool -> A.Value a +run (Composite imp) env = + A.composite (runReaderT imp env) + +{-# INLINE value #-} +value :: (Bool -> A.Value a) -> Composite (Maybe a) +value decoder' = + Composite $ ReaderT $ A.nullableValueComposite . decoder' + +{-# INLINE nonNullValue #-} +nonNullValue :: (Bool -> A.Value a) -> Composite a +nonNullValue decoder' = + Composite $ ReaderT $ A.valueComposite . decoder' diff --git a/src/hasql/Hasql/Decoders/Result.hs b/src/hasql/Hasql/Decoders/Result.hs new file mode 100644 index 0000000000..2fb1e5a372 --- /dev/null +++ b/src/hasql/Hasql/Decoders/Result.hs @@ -0,0 +1,220 @@ +module Hasql.Decoders.Result where + +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.ByteString as ByteString +import qualified Data.Vector as Vector +import qualified Data.Vector.Mutable as MutableVector +import qualified Hasql.Decoders.Row as Row +import Hasql.Errors +import qualified Hasql.LibPq14 as LibPQ +import Hasql.Prelude hiding (many, maybe) +import qualified Hasql.Prelude as Prelude + +newtype Result a + = Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a) + deriving (Functor, Applicative, Monad) + +{-# INLINE run #-} +run :: Result a -> Bool -> LibPQ.Result -> IO (Either ResultError a) +run (Result reader) idt result = + runExceptT (runReaderT reader (idt, result)) + +{-# INLINE pipelineSync #-} +pipelineSync :: Result () +pipelineSync = + checkExecStatus [LibPQ.PipelineSync] + +{-# INLINE noResult #-} +noResult :: Result () +noResult = + checkExecStatus [LibPQ.CommandOk, LibPQ.TuplesOk] + +{-# INLINE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + do + checkExecStatus [LibPQ.CommandOk] + Result + $ ReaderT + $ \(_, result) -> + ExceptT + $ 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 = + first (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) + $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes + +{-# INLINE checkExecStatus #-} +checkExecStatus :: [LibPQ.ExecStatus] -> Result () +checkExecStatus expectedList = + {-# SCC "checkExecStatus" #-} + do + status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result + unless (status `elem` expectedList) $ do + case status of + LibPQ.BadResponse -> serverError + LibPQ.NonfatalError -> serverError + LibPQ.FatalError -> serverError + LibPQ.EmptyQuery -> return () + _ -> unexpectedResult $ "Unexpected result status: " <> fromString (show status) <> ". Expecting one of the following: " <> fromString (show expectedList) + +unexpectedResult :: Text -> Result a +unexpectedResult = + Result . lift . ExceptT . pure . Left . UnexpectedResult + +{-# INLINE serverError #-} +serverError :: Result () +serverError = + Result + $ ReaderT + $ \(_, result) -> ExceptT $ do + code <- + fold <$> LibPQ.resultErrorField result LibPQ.DiagSqlstate + message <- + fold <$> LibPQ.resultErrorField result LibPQ.DiagMessagePrimary + detail <- + LibPQ.resultErrorField result LibPQ.DiagMessageDetail + hint <- + LibPQ.resultErrorField result LibPQ.DiagMessageHint + position <- + parsePosition <$> LibPQ.resultErrorField result LibPQ.DiagStatementPosition + pure $ Left $ ServerError code message detail hint position + where + parsePosition = \case + Nothing -> Nothing + Just pos -> + case Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) pos of + Right pos -> Just pos + _ -> Nothing + +{-# INLINE maybe #-} +maybe :: Row.Row a -> Result (Maybe a) +maybe rowDec = + do + checkExecStatus [LibPQ.TuplesOk] + Result + $ ReaderT + $ \(integerDatetimes, result) -> ExceptT $ do + maxRows <- LibPQ.ntuples result + case maxRows of + 0 -> return (Right Nothing) + 1 -> do + maxCols <- LibPQ.nfields result + let fromRowError (col, err) = RowError 0 col err + fmap Just . first fromRowError <$> Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + +{-# INLINE single #-} +single :: Row.Row a -> Result a +single rowDec = + do + checkExecStatus [LibPQ.TuplesOk] + Result + $ ReaderT + $ \(integerDatetimes, result) -> ExceptT $ do + maxRows <- LibPQ.ntuples result + case maxRows of + 1 -> do + maxCols <- LibPQ.nfields result + let fromRowError (col, err) = RowError 0 col err + first fromRowError <$> Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + +{-# INLINE vector #-} +vector :: Row.Row a -> Result (Vector a) +vector rowDec = + do + checkExecStatus [LibPQ.TuplesOk] + Result + $ ReaderT + $ \(integerDatetimes, result) -> ExceptT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + mvector <- MutableVector.unsafeNew (rowToInt maxRows) + failureRef <- newIORef Nothing + forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left (!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) + Right !x -> MutableVector.unsafeWrite mvector rowIndex x + readIORef failureRef >>= \case + Nothing -> Right <$> Vector.unsafeFreeze mvector + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldl #-} +foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a +foldl step init rowDec = + {-# SCC "foldl" #-} + do + checkExecStatus [LibPQ.TuplesOk] + Result + $ ReaderT + $ \(integerDatetimes, result) -> + ExceptT + $ {-# SCC "traversal" #-} + do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + accRef <- newIORef init + failureRef <- newIORef Nothing + forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left (!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) + Right !x -> modifyIORef' accRef (`step` x) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldr #-} +foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a +foldr step init rowDec = + {-# SCC "foldr" #-} + do + checkExecStatus [LibPQ.TuplesOk] + Result + $ ReaderT + $ \(integerDatetimes, result) -> ExceptT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + accRef <- newIORef init + failureRef <- newIORef Nothing + forMToZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left (!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) + Right !x -> modifyIORef accRef (step x) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral diff --git a/src/hasql/Hasql/Decoders/Results.hs b/src/hasql/Hasql/Decoders/Results.hs new file mode 100644 index 0000000000..b4005b9b69 --- /dev/null +++ b/src/hasql/Hasql/Decoders/Results.hs @@ -0,0 +1,79 @@ +-- | +-- 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.Decoders.Results where + +import qualified Hasql.Decoders.Result as Result +import Hasql.Errors +import qualified Hasql.LibPq14 as LibPQ +import Hasql.Prelude hiding (many, maybe) +import qualified Hasql.Prelude as Prelude + +newtype Results a + = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a) + deriving (Functor, Applicative, Monad) + +instance Filterable Results where + {-# INLINE mapMaybe #-} + mapMaybe fn = + refine (Prelude.maybe (Left "Invalid result") Right . fn) + +{-# INLINE run #-} +run :: Results a -> LibPQ.Connection -> Bool -> IO (Either CommandError a) +run (Results stack) conn idt = + runExceptT (runReaderT stack (idt, conn)) + +{-# INLINE clientError #-} +clientError :: Results a +clientError = + Results + $ ReaderT + $ \(_, connection) -> + ExceptT + $ fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Parse a single result. +{-# INLINE single #-} +single :: Result.Result a -> Results a +single resultDec = + Results + $ ReaderT + $ \(integerDatetimes, connection) -> ExceptT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> + first ResultError <$> Result.run resultDec integerDatetimes result + Nothing -> + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +{-# INLINE dropRemainders #-} +dropRemainders :: Results () +dropRemainders = + {-# SCC "dropRemainders" #-} + Results $ ReaderT $ uncurry loop + where + loop integerDatetimes connection = + getResultMaybe >>= Prelude.maybe (pure ()) onResult + where + getResultMaybe = + lift $ LibPQ.getResult connection + onResult result = + loop integerDatetimes connection <* checkErrors + where + checkErrors = + ExceptT (first ResultError <$> Result.run Result.noResult integerDatetimes result) + +refine :: (a -> Either Text b) -> Results a -> Results b +refine refiner (Results stack) = Results + $ ReaderT + $ \env -> ExceptT $ do + resultEither <- runExceptT $ runReaderT stack env + return $ resultEither >>= first (ResultError . UnexpectedResult) . refiner diff --git a/src/hasql/Hasql/Decoders/Row.hs b/src/hasql/Hasql/Decoders/Row.hs new file mode 100644 index 0000000000..269106a3ba --- /dev/null +++ b/src/hasql/Hasql/Decoders/Row.hs @@ -0,0 +1,68 @@ +module Hasql.Decoders.Row where + +import qualified Hasql.Decoders.Value as Value +import Hasql.Errors +import qualified Hasql.LibPq14 as LibPQ +import Hasql.Prelude hiding (error) +import qualified PostgreSQL.Binary.Decoding as A + +newtype Row a + = Row (ReaderT Env (ExceptT RowError IO) a) + deriving (Functor, Applicative, Monad) + +instance MonadFail Row where + fail = error . ValueError . fromString + +data Env + = Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column) + +-- * Functions + +{-# INLINE run #-} +run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either (Int, RowError) a) +run (Row impl) (result, row, columnsAmount, integerDatetimes) = + do + columnRef <- newIORef 0 + runExceptT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef)) >>= \case + Left e -> do + LibPQ.Col col <- readIORef columnRef + -- -1 because succ is applied before the error is returned + pure $ Left (fromIntegral col - 1, e) + Right x -> pure $ Right x + +{-# INLINE error #-} +error :: RowError -> Row a +error x = + Row (ReaderT (const (ExceptT (pure (Left x))))) + +-- | +-- Next value, decoded using the provided value decoder. +{-# INLINE value #-} +value :: Value.Value a -> Row (Maybe a) +value valueDec = + {-# SCC "value" #-} + Row + $ ReaderT + $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do + col <- readIORef columnRef + writeIORef columnRef (succ col) + if col < columnsAmount + then do + valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col + pure + $ case valueMaybe of + Nothing -> + Right Nothing + Just value -> + fmap Just + $ first ValueError + $ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value + else pure (Left EndOfInput) + +-- | +-- Next value, decoded using the provided value decoder. +{-# INLINE nonNullValue #-} +nonNullValue :: Value.Value a -> Row a +nonNullValue valueDec = + {-# SCC "nonNullValue" #-} + value valueDec >>= maybe (error UnexpectedNull) pure diff --git a/src/hasql/Hasql/Decoders/Value.hs b/src/hasql/Hasql/Decoders/Value.hs new file mode 100644 index 0000000000..3a56635375 --- /dev/null +++ b/src/hasql/Hasql/Decoders/Value.hs @@ -0,0 +1,34 @@ +module Hasql.Decoders.Value where + +import Hasql.Prelude +import qualified PostgreSQL.Binary.Decoding as A + +newtype Value a + = Value (Bool -> A.Value a) + deriving (Functor) + +instance Filterable Value where + {-# INLINE mapMaybe #-} + mapMaybe fn = + refine (maybe (Left "Invalid value") Right . fn) + +{-# INLINE run #-} +run :: Value a -> Bool -> A.Value a +run (Value imp) = imp + +{-# INLINE decoder #-} +decoder :: (Bool -> A.Value a) -> Value a +decoder = + {-# SCC "decoder" #-} + Value + +{-# INLINE decoderFn #-} +decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a +decoderFn fn = + Value $ \integerDatetimes -> A.fn $ fn integerDatetimes + +-- | +-- Refine a value decoder, lifting the possible error to the session level. +{-# INLINE refine #-} +refine :: (a -> Either Text b) -> Value a -> Value b +refine fn (Value run) = Value (A.refine fn . run) diff --git a/src/hasql/Hasql/DynamicStatements/Prelude.hs b/src/hasql/Hasql/DynamicStatements/Prelude.hs new file mode 100644 index 0000000000..359eac7a81 --- /dev/null +++ b/src/hasql/Hasql/DynamicStatements/Prelude.hs @@ -0,0 +1,97 @@ +module Hasql.DynamicStatements.Prelude + ( module Exports, + ) +where + +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, forM, + forM_, mapM, mapM_, + msum, sequence, + sequence_) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Contravariant as Exports +import Data.Functor.Identity as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, + concat, concatMap, elem, + find, foldl, foldl', + foldl1, foldr, foldr1, + isSubsequenceOf, + mapAccumL, mapAccumR, + maximum, maximumBy, + minimum, minimumBy, + notElem, or, product, + sortOn, sum, uncons) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), + Last (..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Semigroup as Exports +import Data.Sequence as Exports (Seq) +import Data.STRef as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (alignment, + sizeOf) +import GHC.Conc as Exports hiding (threadWaitRead, + threadWaitReadSTM, + threadWaitWrite, + threadWaitWriteSTM, + withMVar) +import GHC.Exts as Exports (IsList (..), groupWith, + inline, lazy, sortWith) +import GHC.Generics as Exports (Generic, Generic1) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (all, and, any, + concat, concatMap, elem, + fail, foldl, foldl1, + foldr, foldr1, id, mapM, + mapM_, maximum, minimum, + notElem, or, product, + sequence, sequence_, + sum, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, + readMaybe) +import Unsafe.Coerce as Exports diff --git a/src/hasql/Hasql/DynamicStatements/Session.hs b/src/hasql/Hasql/DynamicStatements/Session.hs new file mode 100644 index 0000000000..5638c4fc14 --- /dev/null +++ b/src/hasql/Hasql/DynamicStatements/Session.hs @@ -0,0 +1,19 @@ +module Hasql.DynamicStatements.Session where + +import qualified Hasql.Decoders as Decoders +import Hasql.DynamicStatements.Prelude +import qualified Hasql.DynamicStatements.Snippet.Defs as SnippetDefs +import qualified Hasql.DynamicStatements.Statement as Statement +import Hasql.Session +import qualified Hasql.Session as Session + +-- | +-- Execute a dynamically parameterized statement, providing a result decoder. +-- +-- This is merely a shortcut, which immediately embeds +-- @Hasql.DynamicStatements.Statement.'Statement.dynamicallyParameterized'@ +-- in @Session@. +-- For details see the docs on that function. +dynamicallyParameterizedStatement :: SnippetDefs.Snippet -> Decoders.Result result -> Bool -> Session result +dynamicallyParameterizedStatement snippet decoder prepared = + Session.statement () (Statement.dynamicallyParameterized snippet decoder prepared) diff --git a/src/hasql/Hasql/DynamicStatements/Snippet.hs b/src/hasql/Hasql/DynamicStatements/Snippet.hs new file mode 100644 index 0000000000..922cc61f82 --- /dev/null +++ b/src/hasql/Hasql/DynamicStatements/Snippet.hs @@ -0,0 +1,9 @@ +module Hasql.DynamicStatements.Snippet + ( Snippet, + param, + encoderAndParam, + sql, + ) +where + +import Hasql.DynamicStatements.Snippet.Defs diff --git a/src/hasql/Hasql/DynamicStatements/Snippet/Defs.hs b/src/hasql/Hasql/DynamicStatements/Snippet/Defs.hs new file mode 100644 index 0000000000..661d2ede85 --- /dev/null +++ b/src/hasql/Hasql/DynamicStatements/Snippet/Defs.hs @@ -0,0 +1,55 @@ +module Hasql.DynamicStatements.Snippet.Defs where + +import Hasql.DynamicStatements.Prelude +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Implicits.Encoders as Encoders + +-- | +-- Composable SQL snippet with parameters injected. +-- Abstracts over placeholders and matching of encoders. +-- +-- It has an instance of `IsString`, so having the @OverloadedStrings@ extension enabled +-- you can construct it directly from string literals. +-- +-- Here's an example: +-- +-- @ +-- selectSubstring :: Text -> Maybe Int32 -> Maybe Int32 -> 'Snippet' +-- selectSubstring string from to = +-- "select substring(" <> 'param' string <> +-- 'foldMap' (\\ x -> " from " <> 'param' x) from <> +-- 'foldMap' (\\ x -> " for " <> 'param' x) to <> +-- ")" +-- @ +-- +-- Having a decoder you can lift it into 'Hasql.Statement.Statement' using +-- 'Hasql.DynamicStatements.Statement.dynamicallyParameterized' or directly execute it in +-- 'Hasql.Session.Session' using +-- 'Hasql.DynamicStatements.Session.dynamicallyParameterizedStatement'. +newtype Snippet = Snippet (Seq SnippetChunk) + +data SnippetChunk + = StringSnippetChunk ByteString + | ParamSnippetChunk (Encoders.Params ()) + +deriving instance Semigroup Snippet + +deriving instance Monoid Snippet + +instance IsString Snippet where + fromString x = Snippet (pure (StringSnippetChunk (fromString x))) + +-- | +-- SQL chunk in ASCII. +sql :: ByteString -> Snippet +sql x = Snippet (pure (StringSnippetChunk x)) + +-- | +-- Parameter encoded using an implicitly derived encoder from the type. +param :: (Encoders.DefaultParamEncoder param) => param -> Snippet +param = encoderAndParam Encoders.defaultParam + +-- | +-- Parameter with an explicitly defined encoder. +encoderAndParam :: Encoders.NullableOrNot Encoders.Value param -> param -> Snippet +encoderAndParam encoder param = Snippet (pure (ParamSnippetChunk (param >$ Encoders.param encoder))) diff --git a/src/hasql/Hasql/DynamicStatements/Statement.hs b/src/hasql/Hasql/DynamicStatements/Statement.hs new file mode 100644 index 0000000000..54a9acca65 --- /dev/null +++ b/src/hasql/Hasql/DynamicStatements/Statement.hs @@ -0,0 +1,63 @@ +module Hasql.DynamicStatements.Statement where + +import qualified Hasql.Decoders as Decoders +import Hasql.DynamicStatements.Prelude +import qualified Hasql.DynamicStatements.Snippet.Defs as SnippetDefs +import Hasql.Statement +import qualified Ptr.ByteString as ByteString +import qualified Ptr.Poking as Poking + +-- | +-- Construct a statement dynamically, specifying the parameters in-place +-- in the declaration of snippet and providing a result decoder and +-- specifying whether the statement should be prepared. +-- +-- The injection of the parameters is handled automatically, +-- generating parametric statements with binary encoders under the hood. +-- +-- This is useful when the SQL of your statement depends on the parameters. +-- Here's an example: +-- +-- @ +-- selectSubstring :: Text -> Maybe Int32 -> Maybe Int32 -> 'Statement' () Text +-- selectSubstring string from to = let +-- snippet = +-- "select substring(" <> Snippet.'SnippetDefs.param' string <> +-- foldMap (mappend " from " . Snippet.'SnippetDefs.param') from <> +-- foldMap (mappend " for " . Snippet.'SnippetDefs.param') to <> +-- ")" +-- decoder = Decoders.'Decoders.singleRow' (Decoders.'Decoders.column' (Decoders.'Decoders.nonNullable' Decoders.'Decoders.text')) +-- in 'dynamicallyParameterized' snippet decoder True +-- @ +-- +-- Without the Snippet API you would have had to implement the same functionality thus: +-- +-- @ +-- selectSubstring' :: Text -> Maybe Int32 -> Maybe Int32 -> 'Statement' () Text +-- selectSubstring' string from to = let +-- sql = case (from, to) of +-- (Just _, Just _) -> "select substring($1 from $2 to $3)" +-- (Just _, Nothing) -> "select substring($1 from $2)" +-- (Nothing, Just _) -> "select substring($1 to $2)" +-- (Nothing, Nothing) -> "select substring($1)" +-- encoder = +-- Encoders.'Encoders.param' (string '>$' Encoders.'Encoders.text') <> +-- foldMap (\\ x -> Encoders.'Encoders.param' (x '>$' Encoders.'Encoders.int8')) from <> +-- foldMap (\\ x -> Encoders.'Encoders.param' (x '>$' Encoders.'Encoders.int8')) to +-- decoder = Decoders.'Decoders.singleRow' (Decoders.'Decoders.column' (Decoders.'Decoders.nonNullable' Decoders.'Decoders.text')) +-- in Statement sql encoder decoder True +-- @ +-- +-- As you can see, the Snippet API abstracts over placeholders and +-- matching encoder generation, thus also protecting you from all sorts of related bugs. +dynamicallyParameterized :: SnippetDefs.Snippet -> Decoders.Result result -> Bool -> Statement () result +dynamicallyParameterized (SnippetDefs.Snippet chunks) decoder prepared = + let step (!paramId, !poking, !encoder) = \case + SnippetDefs.StringSnippetChunk sql -> (paramId, poking <> Poking.bytes sql, encoder) + SnippetDefs.ParamSnippetChunk paramEncoder -> + let newParamId = paramId + 1 + newPoking = poking <> Poking.word8 36 <> Poking.asciiIntegral paramId + newEncoder = encoder <> paramEncoder + in (newParamId, newPoking, newEncoder) + in case foldl' step (1, mempty, mempty) chunks of + (_, poking, encoder) -> Statement (ByteString.poking poking) encoder decoder prepared diff --git a/src/hasql/Hasql/Encoders.hs b/src/hasql/Hasql/Encoders.hs new file mode 100644 index 0000000000..e5840378c7 --- /dev/null +++ b/src/hasql/Hasql/Encoders.hs @@ -0,0 +1,76 @@ +-- | +-- A DSL for declaration of statement parameter encoders. +-- +-- For compactness of names all the types defined here imply being an encoder. +-- E.g., the `Array` type is an __encoder__ of arrays, not the data-structure itself. +module Hasql.Encoders + ( -- * Parameters product + Params, + noParams, + param, + + -- * Nullability + NullableOrNot, + nonNullable, + nullable, + + -- * Value + Value, + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + text, + bytea, + date, + timestamp, + timestamptz, + time, + timetz, + interval, + uuid, + inet, + macaddr, + json, + jsonBytes, + jsonLazyBytes, + jsonb, + jsonbBytes, + jsonbLazyBytes, + int4range, + int8range, + numrange, + tsrange, + tstzrange, + daterange, + int4multirange, + int8multirange, + nummultirange, + tsmultirange, + tstzmultirange, + datemultirange, + name, + oid, + enum, + unknownEnum, + unknown, + array, + foldableArray, + composite, + + -- * Array + Array, + element, + dimension, + + -- * Composite + Composite, + field, + ) +where + +import Hasql.Encoders.All diff --git a/src/hasql/Hasql/Encoders/All.hs b/src/hasql/Hasql/Encoders/All.hs new file mode 100644 index 0000000000..8295f0889c --- /dev/null +++ b/src/hasql/Hasql/Encoders/All.hs @@ -0,0 +1,506 @@ +-- | +-- A DSL for declaration of query parameter encoders. +module Hasql.Encoders.All where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.IP as Iproute +import qualified Hasql.Encoders.Array as Array +import qualified Hasql.Encoders.Params as Params +import qualified Hasql.Encoders.Value as Value +import qualified Hasql.PostgresTypeInfo as PTI +import Hasql.Prelude hiding (bool) +import qualified Hasql.Prelude as Prelude +import qualified PostgreSQL.Binary.Encoding as A +import qualified PostgreSQL.Binary.Range as R +import qualified TextBuilder as C + +-- * Parameters Product Encoder + +-- | +-- Encoder 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., +-- +-- @ +-- someParamsEncoder :: 'Params' (Int64, Maybe Text) +-- someParamsEncoder = +-- ('fst' '>$<' 'param' ('nonNullable' 'int8')) '<>' +-- ('snd' '>$<' 'param' ('nullable' 'text')) +-- @ +-- +-- As a general solution for tuples of any arity, instead of 'fst' and 'snd', +-- consider the functions of the @contrazip@ family +-- from the \"contravariant-extras\" package. +-- E.g., here's how you can achieve the same as the above: +-- +-- @ +-- someParamsEncoder :: 'Params' (Int64, Maybe Text) +-- someParamsEncoder = +-- 'contrazip2' ('param' ('nonNullable' 'int8')) ('param' ('nullable' 'text')) +-- @ +-- +-- Here's how you can implement encoders for custom composite types: +-- +-- @ +-- data Person = Person { name :: Text, gender :: Gender, age :: Int } +-- +-- data Gender = Male | Female +-- +-- personParams :: 'Params' Person +-- personParams = +-- (name '>$<' 'param' ('nonNullable' 'text')) '<>' +-- (gender '>$<' 'param' ('nonNullable' genderValue)) '<>' +-- ('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8')) +-- +-- genderValue :: 'Value' Gender +-- genderValue = 'enum' genderText 'text' where +-- genderText gender = case gender of +-- Male -> "male" +-- Female -> "female" +-- @ +newtype Params a = Params (Params.Params a) + deriving (Contravariant, Divisible, Monoid, Semigroup) + +-- | +-- No parameters. Same as `mempty` and `conquered`. +noParams :: Params () +noParams = mempty + +-- | +-- Lift a single parameter encoder, with its nullability specified, +-- associating it with a single placeholder. +param :: NullableOrNot Value a -> Params a +param = \case + NonNullable (Value valueEnc) -> Params (Params.value valueEnc) + Nullable (Value valueEnc) -> Params (Params.nullableValue valueEnc) + +-- * Nullability + +-- | +-- Extensional specification of nullability over a generic encoder. +data NullableOrNot encoder a where + NonNullable :: encoder a -> NullableOrNot encoder a + Nullable :: encoder a -> NullableOrNot encoder (Maybe a) + +-- | +-- Specify that an encoder produces a non-nullable value. +nonNullable :: encoder a -> NullableOrNot encoder a +nonNullable = NonNullable + +-- | +-- Specify that an encoder produces a nullable value. +nullable :: encoder a -> NullableOrNot encoder (Maybe a) +nullable = Nullable + +-- * Value + +-- | +-- Value encoder. +newtype Value a = Value (Value.Value a) + deriving (Contravariant) + +-- | +-- Encoder of @BOOL@ values. +{-# INLINEABLE bool #-} +bool :: Value Bool +bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool)) + +-- | +-- Encoder of @INT2@ values. +{-# INLINEABLE int2 #-} +int2 :: Value Int16 +int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16)) + +-- | +-- Encoder of @INT4@ values. +{-# INLINEABLE int4 #-} +int4 :: Value Int32 +int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32)) + +-- | +-- Encoder of @INT8@ values. +{-# INLINEABLE int8 #-} +int8 :: Value Int64 +int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64)) + +-- | +-- Encoder of @FLOAT4@ values. +{-# INLINEABLE float4 #-} +float4 :: Value Float +float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4)) + +-- | +-- Encoder of @FLOAT8@ values. +{-# INLINEABLE float8 #-} +float8 :: Value Double +float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8)) + +-- | +-- Encoder of @NUMERIC@ values. +{-# INLINEABLE numeric #-} +numeric :: Value Scientific +numeric = Value (Value.unsafePTIWithShow PTI.numeric (const A.numeric)) + +-- | +-- Encoder of @CHAR@ values. +-- +-- Note that it supports Unicode values and +-- identifies itself under the @TEXT@ OID because of that. +{-# INLINEABLE char #-} +char :: Value Char +char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8)) + +-- | +-- Encoder of @TEXT@ values. +{-# INLINEABLE text #-} +text :: Value Text +text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict)) + +-- | +-- Encoder of @BYTEA@ values. +{-# INLINEABLE bytea #-} +bytea :: Value ByteString +bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict)) + +-- | +-- Encoder of @DATE@ values. +{-# INLINEABLE date #-} +date :: Value Day +date = Value (Value.unsafePTIWithShow PTI.date (const A.date)) + +-- | +-- Encoder of @TIMESTAMP@ values. +{-# INLINEABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int)) + +-- | +-- Encoder of @TIMESTAMPTZ@ values. +{-# INLINEABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int)) + +-- | +-- Encoder of @TIME@ values. +{-# INLINEABLE time #-} +time :: Value TimeOfDay +time = Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int)) + +-- | +-- Encoder of @TIMETZ@ values. +{-# INLINEABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int)) + +-- | +-- Encoder of @INTERVAL@ values. +{-# INLINEABLE interval #-} +interval :: Value DiffTime +interval = Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int)) + +-- | +-- Encoder of @UUID@ values. +{-# INLINEABLE uuid #-} +uuid :: Value UUID +uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid)) + +-- | +-- Encoder of @INET@ values. +{-# INLINEABLE inet #-} +inet :: Value Iproute.IPRange +inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet)) + +-- | +-- Encoder of @MACADDR@ values. +-- +-- Represented as a 6-tuple of Word8 values in big endian order. If +-- you use `ip` library consider using it with `toOctets`. +-- +-- > toOctets >$< macaddr +{-# INLINEABLE macaddr #-} +macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) +macaddr = Value (Value.unsafePTIWithShow PTI.macaddr (const A.macaddr)) + +-- | +-- Encoder of @JSON@ values from JSON AST. +{-# INLINEABLE json #-} +json :: Value Aeson.Value +json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast)) + +-- | +-- Encoder of @JSON@ values from raw JSON. +{-# INLINEABLE jsonBytes #-} +jsonBytes :: Value ByteString +jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes)) + +-- | +-- Encoder of @JSON@ values from raw JSON as lazy ByteString. +{-# INLINEABLE jsonLazyBytes #-} +jsonLazyBytes :: Value LazyByteString.ByteString +jsonLazyBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes_lazy)) + +-- | +-- Encoder of @JSONB@ values from JSON AST. +{-# INLINEABLE jsonb #-} +jsonb :: Value Aeson.Value +jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast)) + +-- | +-- Encoder of @JSONB@ values from raw JSON. +{-# INLINEABLE jsonbBytes #-} +jsonbBytes :: Value ByteString +jsonbBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes)) + +-- | +-- Encoder of @JSONB@ values from raw JSON as lazy ByteString. +{-# INLINEABLE jsonbLazyBytes #-} +jsonbLazyBytes :: Value LazyByteString.ByteString +jsonbLazyBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes_lazy)) + +-- | +-- Encoder of @OID@ values. +{-# INLINEABLE oid #-} +oid :: Value Int32 +oid = Value (Value.unsafePTIWithShow PTI.oid (const A.int4_int32)) + +-- | +-- Encoder of @NAME@ values. +{-# INLINEABLE name #-} +name :: Value Text +name = Value (Value.unsafePTIWithShow PTI.name (const A.text_strict)) + +-- | +-- Encoder of @INT4RANGE@ values. +{-# INLINEABLE int4range #-} +int4range :: Value (R.Range Int32) +int4range = Value (Value.unsafePTIWithShow PTI.int4range (const A.int4range)) + +-- | +-- Encoder of @INT8RANGE@ values. +{-# INLINEABLE int8range #-} +int8range :: Value (R.Range Int64) +int8range = Value (Value.unsafePTIWithShow PTI.int8range (const A.int8range)) + +-- | +-- Encoder of @NUMRANGE@ values. +{-# INLINEABLE numrange #-} +numrange :: Value (R.Range Scientific) +numrange = Value (Value.unsafePTIWithShow PTI.numrange (const A.numrange)) + +-- | +-- Encoder of @TSRANGE@ values. +{-# INLINEABLE tsrange #-} +tsrange :: Value (R.Range LocalTime) +tsrange = Value (Value.unsafePTIWithShow PTI.tsrange (Prelude.bool A.tsrange_float A.tsrange_int)) + +-- | +-- Encoder of @TSTZRANGE@ values. +{-# INLINEABLE tstzrange #-} +tstzrange :: Value (R.Range UTCTime) +tstzrange = Value (Value.unsafePTIWithShow PTI.tstzrange (Prelude.bool A.tstzrange_float A.tstzrange_int)) + +-- | +-- Encoder of @DATERANGE@ values. +{-# INLINEABLE daterange #-} +daterange :: Value (R.Range Day) +daterange = Value (Value.unsafePTIWithShow PTI.daterange (const A.daterange)) + +-- | +-- Encoder of @INT4MULTIRANGE@ values. +{-# INLINEABLE int4multirange #-} +int4multirange :: Value (R.Multirange Int32) +int4multirange = Value (Value.unsafePTIWithShow PTI.int4multirange (const A.int4multirange)) + +-- | +-- Encoder of @INT8MULTIRANGE@ values. +{-# INLINEABLE int8multirange #-} +int8multirange :: Value (R.Multirange Int64) +int8multirange = Value (Value.unsafePTIWithShow PTI.int8multirange (const A.int8multirange)) + +-- | +-- Encoder of @NUMMULTIRANGE@ values. +{-# INLINEABLE nummultirange #-} +nummultirange :: Value (R.Multirange Scientific) +nummultirange = Value (Value.unsafePTIWithShow PTI.nummultirange (const A.nummultirange)) + +-- | +-- Encoder of @TSMULTIRANGE@ values. +{-# INLINEABLE tsmultirange #-} +tsmultirange :: Value (R.Multirange LocalTime) +tsmultirange = Value (Value.unsafePTIWithShow PTI.tsmultirange (Prelude.bool A.tsmultirange_float A.tsmultirange_int)) + +-- | +-- Encoder of @TSTZMULTIRANGE@ values. +{-# INLINEABLE tstzmultirange #-} +tstzmultirange :: Value (R.Multirange UTCTime) +tstzmultirange = Value (Value.unsafePTIWithShow PTI.tstzmultirange (Prelude.bool A.tstzmultirange_float A.tstzmultirange_int)) + +-- | +-- Encoder of @DATEMULTIRANGE@ values. +{-# INLINEABLE datemultirange #-} +datemultirange :: Value (R.Multirange Day) +datemultirange = Value (Value.unsafePTIWithShow PTI.datemultirange (const A.datemultirange)) + +-- | +-- Given a function, +-- which maps a value into a textual enum label used on the DB side, +-- produces an encoder of that value. +{-# INLINEABLE enum #-} +enum :: (a -> Text) -> Value a +enum mapping = Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping)) + +-- | +-- Variation of 'enum' with unknown OID. +-- This function does not identify the type to Postgres, +-- so Postgres must be able to derive the type from context. +-- When you find yourself in such situation just provide an explicit type in the query +-- using the :: operator. +{-# INLINEABLE unknownEnum #-} +unknownEnum :: (a -> Text) -> Value a +unknownEnum mapping = Value (Value.unsafePTI PTI.binaryUnknown (const (A.text_strict . mapping)) (C.text . mapping)) + +-- | +-- Identifies the value with the PostgreSQL's \"unknown\" type, +-- thus leaving it up to Postgres to infer the actual type of the value. +-- +-- The value transimitted is any value encoded in the Postgres' Text data format. +-- For reference, see the +-- +-- section of the Postgres' documentation. +-- +-- __Warning:__ Do not use this as part of composite encoders like 'array' since +-- it is the only encoder that doesn't use the binary format. +{-# INLINEABLE unknown #-} +unknown :: Value ByteString +unknown = Value (Value.unsafePTIWithShow PTI.textUnknown (const A.bytea_strict)) + +-- | +-- Lift an array encoder into a value encoder. +array :: Array a -> Value a +array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = + let encoder env input = A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) + in Value (Value.Value arrayOID arrayOID encoder renderer) + +-- | +-- Lift a composite encoder into a value encoder. +composite :: Composite a -> Value a +composite (Composite encode print) = + Value (Value.unsafePTI PTI.binaryUnknown encodeValue printValue) + where + encodeValue idt val = + A.composite $ encode val idt + printValue val = + "ROW (" <> C.intercalate ", " (print val) <> ")" + +-- | +-- Lift a value encoder of element into a unidimensional array encoder of a foldable value. +-- +-- This function is merely a shortcut to the following expression: +-- +-- @ +-- ('array' . 'dimension' 'foldl'' . 'element') +-- @ +-- +-- You can use it like this: +-- +-- @ +-- vectorOfInts :: Value (Vector Int64) +-- vectorOfInts = 'foldableArray' ('nonNullable' 'int8') +-- @ +-- +-- Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder +-- won't work. You have to explicitly construct the array encoder using 'array'. +{-# INLINE foldableArray #-} +foldableArray :: (Foldable foldable) => NullableOrNot Value element -> Value (foldable element) +foldableArray = array . dimension foldl' . element + +-- * Array + +-- | +-- Generic array encoder. +-- +-- Here's an example of its usage: +-- +-- @ +-- someParamsEncoder :: 'Params' [[Int64]] +-- someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8')))))) +-- @ +-- +-- Please note that the PostgreSQL @IN@ keyword does not accept an array, but rather a syntactical list of +-- values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead. +newtype Array a = Array (Array.Array a) + deriving (Contravariant) + +-- | +-- Lifts a 'Value' encoder into an 'Array' encoder. +element :: NullableOrNot Value a -> Array a +element = \case + NonNullable (Value (Value.Value elementOID arrayOID encoder renderer)) -> + Array (Array.value elementOID arrayOID encoder renderer) + Nullable (Value (Value.Value elementOID arrayOID encoder renderer)) -> + Array (Array.nullableValue elementOID arrayOID encoder renderer) + +-- | +-- Encoder of an array dimension, +-- which thus provides support for multidimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the left-fold operation, +-- such as @Data.Foldable.'foldl''@, +-- which determines the input value. +-- +-- * A component encoder, which can be either another 'dimension' or 'element'. +{-# INLINEABLE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension foldl (Array imp) = Array (Array.dimension foldl imp) + +-- * Composite + +-- | +-- Composite or row-types encoder. +data Composite a + = Composite + (a -> Bool -> A.Composite) + (a -> [C.TextBuilder]) + +instance Contravariant Composite where + contramap f (Composite encode print) = + Composite (encode . f) (print . f) + +instance Divisible Composite where + divide f (Composite encodeL printL) (Composite encodeR printR) = + Composite + (\val idt -> case f val of (lVal, rVal) -> encodeL lVal idt <> encodeR rVal idt) + (\val -> case f val of (lVal, rVal) -> printL lVal <> printR rVal) + conquer = mempty + +instance Semigroup (Composite a) where + Composite encodeL printL <> Composite encodeR printR = + Composite + (\val idt -> encodeL val idt <> encodeR val idt) + (\val -> printL val <> printR val) + +instance Monoid (Composite a) where + mempty = Composite mempty mempty + +-- | Single field of a row-type. +field :: NullableOrNot Value a -> Composite a +field = \case + NonNullable (Value (Value.Value elementOID _ encode print)) -> + Composite + (\val idt -> A.field (PTI.oidWord32 elementOID) (encode idt val)) + (\val -> [print val]) + Nullable (Value (Value.Value elementOID _ encode print)) -> + Composite + ( \val idt -> case val of + Nothing -> A.nullField (PTI.oidWord32 elementOID) + Just val -> A.field (PTI.oidWord32 elementOID) (encode idt val) + ) + ( \case + Nothing -> ["NULL"] + Just val -> [print val] + ) diff --git a/src/hasql/Hasql/Encoders/Array.hs b/src/hasql/Hasql/Encoders/Array.hs new file mode 100644 index 0000000000..81c56d05f8 --- /dev/null +++ b/src/hasql/Hasql/Encoders/Array.hs @@ -0,0 +1,44 @@ +module Hasql.Encoders.Array where + +import qualified Hasql.PostgresTypeInfo as B +import Hasql.Prelude +import qualified PostgreSQL.Binary.Encoding as A +import qualified TextBuilder as C + +data Array a + = Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.TextBuilder) + +instance Contravariant Array where + contramap fn (Array valueOid arrayOid encoder renderer) = + Array valueOid arrayOid (\intDateTimes -> encoder intDateTimes . fn) (renderer . fn) + +{-# INLINE value #-} +value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.TextBuilder) -> Array a +value valueOID arrayOID encoder = + Array valueOID arrayOID (\params -> A.encodingArray . encoder params) + +{-# INLINE nullableValue #-} +nullableValue :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.TextBuilder) -> Array (Maybe a) +nullableValue valueOID arrayOID encoder renderer = + let maybeEncoder params = + maybe A.nullArray (A.encodingArray . encoder params) + maybeRenderer = + maybe (C.string "null") renderer + in Array valueOID arrayOID maybeEncoder maybeRenderer + +{-# INLINE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension fold (Array valueOID arrayOID elEncoder elRenderer) = + let encoder el = + A.dimensionArray fold (elEncoder el) + renderer els = + let folded = + let step builder el = + if C.isEmpty builder + then C.char '[' <> elRenderer el + else builder <> C.string ", " <> elRenderer el + in fold step mempty els + in if C.isEmpty folded + then C.string "[]" + else folded <> C.char ']' + in Array valueOID arrayOID encoder renderer diff --git a/src/hasql/Hasql/Encoders/Params.hs b/src/hasql/Hasql/Encoders/Params.hs new file mode 100644 index 0000000000..f877ce8bc5 --- /dev/null +++ b/src/hasql/Hasql/Encoders/Params.hs @@ -0,0 +1,103 @@ +module Hasql.Encoders.Params where + +import qualified Hasql.Encoders.Value as C +import qualified Hasql.LibPq14 as A +import qualified Hasql.PostgresTypeInfo as D +import Hasql.Prelude +import qualified PostgreSQL.Binary.Encoding as B +import qualified TextBuilder as E + +renderReadable :: Params a -> a -> [Text] +renderReadable (Params _ _ _ printer) params = + printer params + & toList + +compilePreparedStatementData :: Params a -> Bool -> a -> ([A.Oid], [Maybe (ByteString, A.Format)]) +compilePreparedStatementData (Params _ columnsMetadata serializer _) integerDatetimes input = + (oidList, valueAndFormatList) + where + (oidList, formatList) = + columnsMetadata & toList & unzip + valueAndFormatList = + serializer integerDatetimes input + & toList + & zipWith (\format encoding -> (,format) <$> encoding) formatList + +compileUnpreparedStatementData :: Params a -> Bool -> a -> [Maybe (A.Oid, ByteString, A.Format)] +compileUnpreparedStatementData (Params _ columnsMetadata serializer _) integerDatetimes input = + zipWith + ( \(oid, format) encoding -> + ((,,) oid <$> encoding) <*> pure format + ) + (toList columnsMetadata) + (toList (serializer integerDatetimes input)) + +-- | +-- Encoder of some representation of a parameters product. +data Params a = Params + { size :: !Int, + columnsMetadata :: !(DList (A.Oid, A.Format)), + serializer :: Bool -> a -> DList (Maybe ByteString), + printer :: a -> DList Text + } + +instance Contravariant Params where + contramap fn (Params size columnsMetadata oldSerializer oldPrinter) = Params {..} + where + serializer idt = oldSerializer idt . fn + printer = oldPrinter . fn + +instance Divisible Params where + divide + divisor + (Params leftSize leftColumnsMetadata leftSerializer leftPrinter) + (Params rightSize rightColumnsMetadata rightSerializer rightPrinter) = + Params + { size = leftSize + rightSize, + columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata, + serializer = \idt input -> case divisor input of + (leftInput, rightInput) -> leftSerializer idt leftInput <> rightSerializer idt rightInput, + printer = \input -> case divisor input of + (leftInput, rightInput) -> leftPrinter leftInput <> rightPrinter rightInput + } + conquer = + Params + { size = 0, + columnsMetadata = mempty, + serializer = mempty, + printer = mempty + } + +instance Semigroup (Params a) where + Params leftSize leftColumnsMetadata leftSerializer leftPrinter <> Params rightSize rightColumnsMetadata rightSerializer rightPrinter = + Params + { size = leftSize + rightSize, + columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata, + serializer = \idt input -> leftSerializer idt input <> rightSerializer idt input, + printer = \input -> leftPrinter input <> rightPrinter input + } + +instance Monoid (Params a) where + mempty = conquer + +value :: C.Value a -> Params a +value (C.Value valueOID _ serialize print) = + Params + { size = 1, + columnsMetadata = pure (pqOid, format), + serializer = \idt -> pure . Just . B.encodingBytes . serialize idt, + printer = pure . E.toText . print + } + where + D.OID _ pqOid format = valueOID + +nullableValue :: C.Value a -> Params (Maybe a) +nullableValue (C.Value valueOID _ serialize print) = + Params + { size = 1, + columnsMetadata = pure (pqOid, format), + serializer = \idt -> pure . fmap (B.encodingBytes . serialize idt), + printer = pure . maybe "null" (E.toText . print) + } + where + D.OID _ pqOid format = valueOID diff --git a/src/hasql/Hasql/Encoders/Value.hs b/src/hasql/Hasql/Encoders/Value.hs new file mode 100644 index 0000000000..0470712d19 --- /dev/null +++ b/src/hasql/Hasql/Encoders/Value.hs @@ -0,0 +1,24 @@ +module Hasql.Encoders.Value where + +import qualified Hasql.PostgresTypeInfo as PTI +import Hasql.Prelude +import qualified PostgreSQL.Binary.Encoding as B +import qualified TextBuilder as C + +data Value a + = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.TextBuilder) + +instance Contravariant Value where + {-# INLINE contramap #-} + contramap f (Value valueOID arrayOID encode render) = + Value valueOID arrayOID (\integerDatetimes input -> encode integerDatetimes (f input)) (render . f) + +{-# INLINE unsafePTI #-} +unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> (a -> C.TextBuilder) -> Value a +unsafePTI pti = + Value (PTI.ptiOID pti) (fromMaybe (error "No array OID") (PTI.ptiArrayOID pti)) + +{-# INLINE unsafePTIWithShow #-} +unsafePTIWithShow :: (Show a) => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a +unsafePTIWithShow pti encode = + unsafePTI pti encode (C.string . show) diff --git a/src/hasql/Hasql/Errors.hs b/src/hasql/Hasql/Errors.hs new file mode 100644 index 0000000000..5c809338f7 --- /dev/null +++ b/src/hasql/Hasql/Errors.hs @@ -0,0 +1,152 @@ +module Hasql.Errors where + +import qualified Data.ByteString.Char8 as BC +import Hasql.Prelude + +-- | Error during execution of a session. +data SessionError + = -- | Error during the execution of a query. + -- Comes packed with the query template and a textual representation of the provided params. + QueryError + -- | SQL template. + ByteString + -- | Parameters rendered as human-readable SQL literals. + [Text] + -- | Error details. + CommandError + | -- | Error during the execution of a pipeline. + PipelineError + -- | Error details. + CommandError + deriving (Show, Eq) + +instance Exception SessionError where + displayException = \case + QueryError query params commandError -> + let queryContext :: Maybe (ByteString, Int) + queryContext = case commandError of + ClientError _ -> Nothing + ResultError resultError -> case resultError of + ServerError _ message _ _ (Just position) -> Just (message, position) + _ -> Nothing + + -- find the line number and position of the error + findLineAndPos :: ByteString -> Int -> (Int, Int) + findLineAndPos byteString errorPos = + let (_, line, pos) = + BC.foldl' + ( \(total, line, pos) c -> + case total + 1 of + 0 -> (total, line, pos) + cursor + | cursor == errorPos -> (-1, line, pos + 1) + | c == '\n' -> (total + 1, line + 1, 0) + | otherwise -> (total + 1, line, pos + 1) + ) + (0, 1, 0) + byteString + in (line, pos) + + formatErrorContext :: ByteString -> ByteString -> Int -> ByteString + formatErrorContext query message errorPos = + let lines = BC.lines query + (lineNum, linePos) = findLineAndPos query errorPos + in BC.unlines (take lineNum lines) + <> BC.replicate (linePos - 1) ' ' + <> "^ " + <> message + + prettyQuery :: ByteString + prettyQuery = case queryContext of + Nothing -> query + Just (message, pos) -> formatErrorContext query message pos + in "QueryError!\n" + <> "\n Query:\n" + <> BC.unpack prettyQuery + <> "\n" + <> "\n Params: " + <> show params + <> "\n Error: " + <> renderCommandErrorAsReason commandError + PipelineError commandError -> + "PipelineError!\n Reason: " <> renderCommandErrorAsReason commandError + where + renderCommandErrorAsReason = \case + ClientError (Just message) -> "Client error: " <> show message + ClientError Nothing -> "Client error without details" + ResultError resultError -> case resultError of + ServerError code message details hint _ -> + "Server error " + <> BC.unpack code + <> ": " + <> BC.unpack message + <> maybe "" (\d -> "\n Details: " <> BC.unpack d) details + <> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint + UnexpectedResult message -> "Unexpected result: " <> show message + RowError row column rowError -> + "Error in row " <> show row <> ", column " <> show column <> ": " <> show rowError + UnexpectedAmountOfRows amount -> + "Unexpected amount of rows: " <> show amount + +-- | +-- An error of some command in the session. +data CommandError + = -- | + -- An error on the client-side, + -- with a message generated by the \"libpq\" library. + -- Usually indicates problems with connection. + ClientError (Maybe ByteString) + | -- | + -- Some error with a command result. + ResultError ResultError + deriving (Show, Eq) + +-- | +-- An error with a command result. +data ResultError + = -- | An error reported by the DB. + ServerError + -- | __Code__. The SQLSTATE code for the error. It's recommended to use + -- to work with those. + ByteString + -- | __Message__. The primary human-readable error message(typically one + -- line). Always present. + ByteString + -- | __Details__. An optional secondary error message carrying more + -- detail about the problem. Might run to multiple lines. + (Maybe ByteString) + -- | __Hint__. An optional suggestion on what to do about the problem. + -- This is intended to differ from detail in that it offers advice + -- (potentially inappropriate) rather than hard facts. Might run to + -- multiple lines. + (Maybe ByteString) + -- | __Position__. Error cursor position as an index into the original + -- statement string. Positions are measured in characters not bytes. + (Maybe Int) + | -- | + -- 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 indexes of the row and column. + RowError Int Int RowError + | -- | + -- An unexpected amount of rows. + UnexpectedAmountOfRows Int + deriving (Show, Eq) + +-- | +-- An error during the decoding of a specific row. +data RowError + = -- | + -- Appears on the attempt to parse more columns than there are in the result. + EndOfInput + | -- | + -- Appears on the attempt to parse a @NULL@ as some value. + UnexpectedNull + | -- | + -- Appears when a wrong value parser is used. + -- Comes with the error details. + ValueError Text + deriving (Show, Eq) diff --git a/src/hasql/Hasql/IO.hs b/src/hasql/Hasql/IO.hs new file mode 100644 index 0000000000..d57c4d02ad --- /dev/null +++ b/src/hasql/Hasql/IO.hs @@ -0,0 +1,156 @@ +-- | +-- An API of low-level IO operations. +module Hasql.IO where + +import qualified Hasql.Commands as Commands +import qualified Hasql.Decoders.Result as ResultDecoders +import qualified Hasql.Decoders.Results as ResultsDecoders +import qualified Hasql.Encoders.Params as ParamsEncoders +import Hasql.Errors +import qualified Hasql.LibPq14 as LibPQ +import Hasql.Prelude +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry + +{-# INLINE acquireConnection #-} +acquireConnection :: ByteString -> IO LibPQ.Connection +acquireConnection = + LibPQ.connectdb + +{-# INLINE acquirePreparedStatementRegistry #-} +acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry +acquirePreparedStatementRegistry = + PreparedStatementRegistry.new + +{-# INLINE releaseConnection #-} +releaseConnection :: LibPQ.Connection -> IO () +releaseConnection = LibPQ.finish + +{-# INLINE checkConnectionStatus #-} +checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString)) +checkConnectionStatus c = + do + s <- LibPQ.status c + case s of + LibPQ.ConnectionOk -> return Nothing + _ -> fmap Just (LibPQ.errorMessage c) + +{-# INLINE checkServerVersion #-} +checkServerVersion :: LibPQ.Connection -> IO (Maybe Int) +checkServerVersion c = + fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c) + +{-# INLINE getIntegerDatetimes #-} +getIntegerDatetimes :: LibPQ.Connection -> IO Bool +getIntegerDatetimes c = + decodeValue <$> LibPQ.parameterStatus c "integer_datetimes" + where + decodeValue = + \case + Just "on" -> True + _ -> False + +{-# INLINE initConnection #-} +initConnection :: LibPQ.Connection -> IO () +initConnection c = + void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning)) + +{-# INLINE getResults #-} +getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a) +getResults connection integerDatetimes decoder = + {-# SCC "getResults" #-} + (<*) <$> get <*> dropRemainders + where + get = + ResultsDecoders.run decoder connection integerDatetimes + dropRemainders = + ResultsDecoders.run ResultsDecoders.dropRemainders connection integerDatetimes + +{-# INLINE getPreparedStatementKey #-} +getPreparedStatementKey :: + LibPQ.Connection -> + PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> + [LibPQ.Oid] -> + IO (Either CommandError ByteString) +getPreparedStatementKey connection registry template oidList = + {-# SCC "getPreparedStatementKey" #-} + PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry + where + localKey = + PreparedStatementRegistry.LocalKey template oidList + onNewRemoteKey key = + do + sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) + resultsMapping <$> getResults connection undefined (resultsDecoder sent) + where + resultsDecoder sent = + if sent + then ResultsDecoders.single ResultDecoders.noResult + else ResultsDecoders.clientError + resultsMapping = + \case + Left x -> (False, Left x) + Right _ -> (True, Right key) + onOldRemoteKey key = + pure (pure key) + +{-# INLINE checkedSend #-} +checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ()) +checkedSend connection send = + send >>= \case + False -> Left . ClientError <$> LibPQ.errorMessage connection + True -> pure (Right ()) + +{-# INLINE sendPreparedParametricStatement #-} +sendPreparedParametricStatement :: + LibPQ.Connection -> + PreparedStatementRegistry.PreparedStatementRegistry -> + Bool -> + ByteString -> + ParamsEncoders.Params a -> + a -> + IO (Either CommandError ()) +sendPreparedParametricStatement connection registry integerDatetimes template encoder input = + runExceptT $ do + key <- ExceptT $ getPreparedStatementKey connection registry template oidList + ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary + where + (oidList, valueAndFormatList) = + ParamsEncoders.compilePreparedStatementData encoder integerDatetimes input + +{-# INLINE sendUnpreparedParametricStatement #-} +sendUnpreparedParametricStatement :: + LibPQ.Connection -> + Bool -> + ByteString -> + ParamsEncoders.Params a -> + a -> + IO (Either CommandError ()) +sendUnpreparedParametricStatement connection integerDatetimes template encoder input = + checkedSend connection + $ LibPQ.sendQueryParams + connection + template + (ParamsEncoders.compileUnpreparedStatementData encoder integerDatetimes input) + LibPQ.Binary + +{-# INLINE sendParametricStatement #-} +sendParametricStatement :: + LibPQ.Connection -> + Bool -> + PreparedStatementRegistry.PreparedStatementRegistry -> + ByteString -> + ParamsEncoders.Params a -> + Bool -> + a -> + IO (Either CommandError ()) +sendParametricStatement connection integerDatetimes registry template encoder prepared params = + {-# SCC "sendParametricStatement" #-} + if prepared + then sendPreparedParametricStatement connection registry integerDatetimes template encoder params + else sendUnpreparedParametricStatement connection integerDatetimes template encoder params + +{-# INLINE sendNonparametricStatement #-} +sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ()) +sendNonparametricStatement connection sql = + checkedSend connection $ LibPQ.sendQuery connection sql diff --git a/src/hasql/Hasql/Implicits/Encoders.hs b/src/hasql/Hasql/Implicits/Encoders.hs new file mode 100644 index 0000000000..0bf58430c7 --- /dev/null +++ b/src/hasql/Hasql/Implicits/Encoders.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} + +module Hasql.Implicits.Encoders where + +import qualified Data.Aeson as Aeson +import Hasql.Encoders +import Hasql.Implicits.Prelude hiding (bool) + +-- | Provides a default implementation of parameter encoder. +class DefaultParamEncoder a where + -- | Default parameter encoder with nullability specified. + defaultParam :: NullableOrNot Value a + +#define INSTANCES(VALUE, ENCODER) \ +instance DefaultParamEncoder VALUE where { \ + defaultParam = nonNullable ENCODER; \ +}; \ +instance DefaultParamEncoder [VALUE] where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder [Maybe VALUE] where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder [[VALUE]] where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder [[Maybe VALUE]] where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Vector VALUE) where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Vector (Maybe VALUE)) where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Vector (Vector VALUE)) where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Vector (Vector (Maybe VALUE))) where { \ + defaultParam = (nonNullable . array . dimension foldlStrict . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe VALUE) where { \ + defaultParam = nullable ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe [VALUE]) where { \ + defaultParam = (nullable . array . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe [Maybe VALUE]) where { \ + defaultParam = (nullable . array . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe [[VALUE]]) where { \ + defaultParam = (nullable . array . dimension foldlStrict . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe [[Maybe VALUE]]) where { \ + defaultParam = (nullable . array . dimension foldlStrict . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe (Vector VALUE)) where { \ + defaultParam = (nullable . array . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe (Vector (Maybe VALUE))) where { \ + defaultParam = (nullable . array . dimension foldlStrict . element . nullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe (Vector (Vector VALUE))) where { \ + defaultParam = (nullable . array . dimension foldlStrict . dimension foldlStrict . element . nonNullable) ENCODER; \ +}; \ +instance DefaultParamEncoder (Maybe (Vector (Vector (Maybe VALUE)))) where { \ + defaultParam = (nullable . array . dimension foldlStrict . dimension foldlStrict . element . nullable) ENCODER; \ +} + +{- ORMOLU_DISABLE -} +INSTANCES(Char, char) +INSTANCES(Double, float8) +INSTANCES(Float, float4) +INSTANCES(Int16, int2) +INSTANCES(Int32, int4) +INSTANCES(Int64, int8) +INSTANCES(ByteString, bytea) +INSTANCES(Scientific, numeric) +INSTANCES(Text, text) +INSTANCES(UTCTime, timestamptz) +INSTANCES(Aeson.Value, jsonb) +INSTANCES(UUID, uuid) +INSTANCES(Day, date) +INSTANCES(DiffTime, interval) +INSTANCES(TimeOfDay, time) +INSTANCES(LocalTime, timestamp) +INSTANCES((TimeOfDay, TimeZone), timetz) +INSTANCES(IPRange, inet) +INSTANCES(Bool, bool) +{- ORMOLU_ENABLE -} + +#undef INSTANCES diff --git a/src/hasql/Hasql/Implicits/Prelude.hs b/src/hasql/Hasql/Implicits/Prelude.hs new file mode 100644 index 0000000000..b534725b94 --- /dev/null +++ b/src/hasql/Hasql/Implicits/Prelude.hs @@ -0,0 +1,108 @@ +module Hasql.Implicits.Prelude + ( module Exports, + foldlStrict, + ) +where + +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, forM, + forM_, mapM, mapM_, + msum, sequence, + sequence_) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Contravariant as Exports +import Data.Functor.Identity as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.IP as Exports (IPRange) +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, + concat, concatMap, elem, + find, foldl, foldl', + foldl1, foldr, foldr1, + isSubsequenceOf, + mapAccumL, mapAccumR, + maximum, maximumBy, + minimum, minimumBy, + notElem, or, product, + sortOn, sum, uncons) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), + Last (..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Scientific as Exports (Scientific) +import Data.Semigroup as Exports +import Data.Sequence as Exports (Seq) +import Data.STRef as Exports +import Data.String as Exports +import Data.Text as Exports (Text) +import Data.Time as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.UUID as Exports (UUID) +import Data.Vector as Exports (Vector) +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (alignment, + sizeOf) +import GHC.Conc as Exports hiding (threadWaitRead, + threadWaitReadSTM, + threadWaitWrite, + threadWaitWriteSTM, + withMVar) +import GHC.Exts as Exports (IsList (..), groupWith, + inline, lazy, sortWith) +import GHC.Generics as Exports (Generic, Generic1) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (all, and, any, + concat, concatMap, elem, + fail, foldl, foldl1, + foldr, foldr1, id, mapM, + mapM_, maximum, minimum, + notElem, or, product, + sequence, sequence_, + sum, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, + readMaybe) +import Unsafe.Coerce as Exports + +{-# INLINE foldlStrict #-} +foldlStrict :: (Foldable foldable) => (b -> a -> b) -> b -> foldable a -> b +foldlStrict = foldl' diff --git a/src/hasql/Hasql/LibPq14.hs b/src/hasql/Hasql/LibPq14.hs new file mode 100644 index 0000000000..16f38267bd --- /dev/null +++ b/src/hasql/Hasql/LibPq14.hs @@ -0,0 +1,91 @@ +module Hasql.LibPq14 + ( module Base, + + -- * Updated and new types + Mappings.ExecStatus (..), + Mappings.PipelineStatus (..), + + -- * Updated and new procedures + resultStatus, + pipelineStatus, + enterPipelineMode, + exitPipelineMode, + pipelineSync, + sendFlushRequest, + ) +where + +import Database.PostgreSQL.LibPQ as Base hiding + (ExecStatus (..), + PipelineStatus (..), + enterPipelineMode, + exitPipelineMode, + pipelineStatus, + pipelineSync, + resultStatus, + sendFlushRequest) +import qualified Database.PostgreSQL.LibPQ.Internal as BaseInternal +import qualified Hasql.LibPq14.Ffi as Ffi +import qualified Hasql.LibPq14.Mappings as Mappings +import Hasql.Prelude + +resultStatus :: Result -> IO Mappings.ExecStatus +resultStatus result = do + -- Unsafe-coercing because the constructor is not exposed by the lib, + -- but it's implemented as a newtype over ForeignPtr. + -- Since internal changes in the \"postgresql-lipbq\" may break this, + -- it requires us to avoid using an open dependency range on it. + ffiStatus <- withForeignPtr (unsafeCoerce result) Ffi.resultStatus + decodeProcedureResult "resultStatus" Mappings.decodeExecStatus ffiStatus + +pipelineStatus :: + Connection -> + IO Mappings.PipelineStatus +pipelineStatus = + parameterlessProcedure "pipelineStatus" Ffi.pipelineStatus Mappings.decodePipelineStatus + +enterPipelineMode :: + Connection -> + IO Bool +enterPipelineMode = + parameterlessProcedure "enterPipelineMode" Ffi.enterPipelineMode Mappings.decodeBool + +exitPipelineMode :: + Connection -> + IO Bool +exitPipelineMode = + parameterlessProcedure "exitPipelineMode" Ffi.exitPipelineMode Mappings.decodeBool + +pipelineSync :: + Connection -> + IO Bool +pipelineSync = + parameterlessProcedure "pipelineSync" Ffi.pipelineSync Mappings.decodeBool + +sendFlushRequest :: + Connection -> + IO Bool +sendFlushRequest = + parameterlessProcedure "sendFlushRequest" Ffi.sendFlushRequest Mappings.decodeBool + +parameterlessProcedure :: + (Show a) => + String -> + (Ptr BaseInternal.PGconn -> IO a) -> + (a -> Maybe b) -> + Connection -> + IO b +parameterlessProcedure label procedure decoder connection = do + ffiResult <- BaseInternal.withConn connection procedure + decodeProcedureResult label decoder ffiResult + +decodeProcedureResult :: + (Show a) => + String -> + (a -> Maybe b) -> + a -> + IO b +decodeProcedureResult label decoder ffiResult = + case decoder ffiResult of + Just res -> pure res + Nothing -> fail ("Failed to decode result of " <> label <> " from: " <> show ffiResult) diff --git a/src/hasql/Hasql/LibPq14/Ffi.hs b/src/hasql/Hasql/LibPq14/Ffi.hs new file mode 100644 index 0000000000..0c65799669 --- /dev/null +++ b/src/hasql/Hasql/LibPq14/Ffi.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CApiFFI #-} + +module Hasql.LibPq14.Ffi where + +import Database.PostgreSQL.LibPQ.Internal +import Foreign.C.Types (CInt (..)) +import Hasql.Prelude + +foreign import capi "libpq-fe.h PQresultStatus" + resultStatus :: Ptr () -> IO CInt + +foreign import capi "libpq-fe.h PQpipelineStatus" + pipelineStatus :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQenterPipelineMode" + enterPipelineMode :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQexitPipelineMode" + exitPipelineMode :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQpipelineSync" + pipelineSync :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQsendFlushRequest" + sendFlushRequest :: Ptr PGconn -> IO CInt diff --git a/src/hasql/Hasql/LibPq14/Mappings.hsc b/src/hasql/Hasql/LibPq14/Mappings.hsc new file mode 100644 index 0000000000..120e67cdf0 --- /dev/null +++ b/src/hasql/Hasql/LibPq14/Mappings.hsc @@ -0,0 +1,71 @@ +module Hasql.LibPq14.Mappings where + +#include "libpq-fe.h" + +import Foreign.C.Types (CInt (..)) +import Hasql.Prelude + +data ExecStatus + = EmptyQuery + | CommandOk + | TuplesOk + | CopyOut + | CopyIn + | CopyBoth + | BadResponse + | NonfatalError + | FatalError + | SingleTuple + | PipelineSync + | PipelineAbort + deriving (Eq, Show) + +decodeExecStatus :: CInt -> Maybe ExecStatus +decodeExecStatus = \case + (#const PGRES_EMPTY_QUERY) -> Just EmptyQuery + (#const PGRES_COMMAND_OK) -> Just CommandOk + (#const PGRES_TUPLES_OK) -> Just TuplesOk + (#const PGRES_COPY_OUT) -> Just CopyOut + (#const PGRES_COPY_IN) -> Just CopyIn + (#const PGRES_COPY_BOTH) -> Just CopyBoth + (#const PGRES_BAD_RESPONSE) -> Just BadResponse + (#const PGRES_NONFATAL_ERROR) -> Just NonfatalError + (#const PGRES_FATAL_ERROR) -> Just FatalError + (#const PGRES_SINGLE_TUPLE) -> Just SingleTuple + (#const PGRES_PIPELINE_SYNC) -> Just PipelineSync + (#const PGRES_PIPELINE_ABORTED) -> Just PipelineAbort + _ -> Nothing + +encodeExecStatus :: ExecStatus -> CInt +encodeExecStatus = \case + EmptyQuery -> #const PGRES_EMPTY_QUERY + CommandOk -> #const PGRES_COMMAND_OK + TuplesOk -> #const PGRES_TUPLES_OK + CopyOut -> #const PGRES_COPY_OUT + CopyIn -> #const PGRES_COPY_IN + CopyBoth -> #const PGRES_COPY_BOTH + BadResponse -> #const PGRES_BAD_RESPONSE + NonfatalError -> #const PGRES_NONFATAL_ERROR + FatalError -> #const PGRES_FATAL_ERROR + SingleTuple -> #const PGRES_SINGLE_TUPLE + PipelineSync -> #const PGRES_PIPELINE_SYNC + PipelineAbort -> #const PGRES_PIPELINE_ABORTED + +data PipelineStatus + = PipelineOn + | PipelineOff + | PipelineAborted + deriving (Eq, Show) + +decodePipelineStatus :: CInt -> Maybe PipelineStatus +decodePipelineStatus = \case + (#const PQ_PIPELINE_ON) -> Just PipelineOn + (#const PQ_PIPELINE_OFF) -> Just PipelineOff + (#const PQ_PIPELINE_ABORTED) -> Just PipelineAborted + _ -> Nothing + +decodeBool :: CInt -> Maybe Bool +decodeBool = \case + 0 -> Just False + 1 -> Just True + _ -> Nothing diff --git a/src/hasql/Hasql/Notifications.hs b/src/hasql/Hasql/Notifications.hs new file mode 100644 index 0000000000..fbdc55abe9 --- /dev/null +++ b/src/hasql/Hasql/Notifications.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} + +-- | +-- This module has functions to send commands LISTEN and NOTIFY to the database server. +-- It also has a function to wait for and handle notifications on a database connection. +-- +-- For more information check the [PostgreSQL documentation](https://www.postgresql.org/docs/current/libpq-notify.html). +module Hasql.Notifications + ( notifyPool, + notify, + listen, + unlisten, + waitForNotifications, + PgIdentifier, + toPgIdentifier, + fromPgIdentifier, + FatalError (..), + ) +where +#if defined(mingw32_HOST_OS) +import Control.Concurrent (threadDelay) +#else +import Control.Concurrent (threadDelay, threadWaitRead) +#endif +import Control.Exception (Exception, throw) +import Control.Monad (forever, unless, void, + when) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant (contramap) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Database.PostgreSQL.LibPQ as PQ +import Hasql.Connection (Connection, + withLibPQConnection) +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE +import Hasql.Pool (Pool, UsageError, use) +import Hasql.Session (run, sql, statement) +import qualified Hasql.Session as S +import qualified Hasql.Statement as HST + +import Prelude + +-- | A wrapped text that represents a properly escaped and quoted PostgreSQL identifier +newtype PgIdentifier = PgIdentifier Text deriving (Show) + +-- | Uncatchable exceptions thrown and never caught. +newtype FatalError = FatalError {fatalErrorMessage :: String} + +instance Exception FatalError + +instance Show FatalError where + show = fatalErrorMessage + +-- | Given a PgIdentifier returns the wrapped text +fromPgIdentifier :: PgIdentifier -> Text +fromPgIdentifier (PgIdentifier bs) = bs + +-- | Given a text returns a properly quoted and escaped PgIdentifier +toPgIdentifier :: Text -> PgIdentifier +toPgIdentifier x = + PgIdentifier $ "\"" <> strictlyReplaceQuotes x <> "\"" + where + strictlyReplaceQuotes :: Text -> Text + strictlyReplaceQuotes = T.replace "\"" ("\"\"" :: Text) + +-- | Given a Hasql Pool, a channel and a message sends a notify command to the database +notifyPool :: + -- | Pool from which the connection will be used to issue a NOTIFY command. + Pool -> + -- | Channel where to send the notification + Text -> + -- | Payload to be sent with the notification + Text -> + IO (Either UsageError ()) +notifyPool pool channel mesg = + use pool (statement (channel, mesg) callStatement) + where + callStatement = HST.Statement ("SELECT pg_notify" <> "($1, $2)") encoder HD.noResult False + encoder = contramap fst (HE.param $ HE.nonNullable HE.text) <> contramap snd (HE.param $ HE.nonNullable HE.text) + +-- | Given a Hasql Connection, a channel and a message sends a notify command to the database +notify :: + -- | Connection to be used to send the NOTIFY command + Connection -> + -- | Channel where to send the notification + PgIdentifier -> + -- | Payload to be sent with the notification + Text -> + IO (Either S.SessionError ()) +notify con channel mesg = + run (sql $ T.encodeUtf8 ("NOTIFY " <> fromPgIdentifier channel <> ", '" <> mesg <> "'")) con + +-- | +-- Given a Hasql Connection and a channel sends a listen command to the database. +-- Once the connection sends the LISTEN command the server register its interest in the channel. +-- Hence it's important to keep track of which connection was used to open the listen command. +-- +-- Example of listening and waiting for a notification: +-- +-- @ +-- import System.Exit (die) +-- +-- import Hasql.Connection +-- import Hasql.Connection.Setting +-- import Hasql.Connection.Setting.Connection +-- import Hasql.Notifications +-- +-- main :: IO () +-- main = do +-- dbOrError <- acquire [ connection $ string "postgres://localhost/db_name" ] +-- case dbOrError of +-- Right db -> do +-- let channelToListen = toPgIdentifier "sample-channel" +-- listen db channelToListen +-- waitForNotifications (\channel _ -> print $ "Just got notification on channel " <> channel) db +-- _ -> die "Could not open database connection" +-- @ +listen :: + -- | Connection to be used to send the LISTEN command + Connection -> + -- | Channel this connection will be registered to listen to + PgIdentifier -> + IO () +listen con channel = + void $ withLibPQConnection con execListen + where + execListen = executeOrPanic $ T.encodeUtf8 $ "LISTEN " <> fromPgIdentifier channel + +-- | Given a Hasql Connection and a channel sends a unlisten command to the database +unlisten :: + -- | Connection currently registerd by a previous 'listen' call + Connection -> + -- | Channel this connection will be deregistered from + PgIdentifier -> + IO () +unlisten con channel = + void $ withLibPQConnection con execUnlisten + where + execUnlisten = executeOrPanic $ T.encodeUtf8 $ "UNLISTEN " <> fromPgIdentifier channel + +executeOrPanic :: ByteString -> PQ.Connection -> IO () +executeOrPanic cmd pqCon = do + mResult <- PQ.exec pqCon cmd + case mResult of + Nothing -> do + mError <- PQ.errorMessage pqCon + panic $ maybe ("Error executing" <> show cmd) (T.unpack . T.decodeUtf8Lenient) mError + Just result -> do + status <- PQ.resultStatus result + when (status == PQ.FatalError) $ do + mError <- PQ.resultErrorMessage result + panic $ maybe ("Error executing" <> show cmd) (T.unpack . T.decodeUtf8Lenient) mError + +-- | +-- Given a function that handles notifications and a Hasql connection it will listen +-- on the database connection and call the handler everytime a message arrives. +-- +-- The message handler passed as first argument needs two parameters channel and payload. +-- See an example of handling notification on a separate thread: +-- +-- @ +-- import Control.Concurrent.Async (async) +-- import Control.Monad (void) +-- import System.Exit (die) +-- +-- import Hasql.Connection +-- import Hasql.Connection.Setting +-- import Hasql.Connection.Setting.Connection +-- import Hasql.Notifications +-- +-- notificationHandler :: ByteString -> ByteString -> IO() +-- notificationHandler channel payload = +-- void $ async do +-- print $ "Handle payload " <> payload <> " in its own thread" +-- +-- main :: IO () +-- main = do +-- dbOrError <- acquire [ connection $ string "postgres://localhost/db_name" ] +-- case dbOrError of +-- Right db -> do +-- let channelToListen = toPgIdentifier "sample-channel" +-- listen db channelToListen +-- waitForNotifications notificationHandler db +-- _ -> die "Could not open database connection" +-- @ +waitForNotifications :: + -- | Callback function to handle incoming notifications + (ByteString -> ByteString -> IO ()) -> + -- | Connection where we will listen to + Connection -> + IO () +waitForNotifications sendNotification con = + withLibPQConnection con $ void . forever . pqFetch + where + pqFetch pqCon = do + mNotification <- PQ.notifies pqCon + case mNotification of + Nothing -> do + mfd <- PQ.socket pqCon + case mfd of + Nothing -> void $ threadDelay 1000000 +#if defined(mingw32_HOST_OS) + Just _ -> do + void $ threadDelay 1000000 +#else + Just fd -> do + void $ threadWaitRead fd +#endif + result <- PQ.consumeInput pqCon + unless result $ do + mError <- PQ.errorMessage pqCon + panic $ maybe "Error checking for PostgreSQL notifications" (T.unpack . T.decodeUtf8Lenient) mError + Just notification -> + sendNotification (PQ.notifyRelname notification) (PQ.notifyExtra notification) + +panic :: String -> a +panic a = throw (FatalError a) diff --git a/src/hasql/Hasql/Pipeline.hs b/src/hasql/Hasql/Pipeline.hs new file mode 100644 index 0000000000..dce834f590 --- /dev/null +++ b/src/hasql/Hasql/Pipeline.hs @@ -0,0 +1,7 @@ +module Hasql.Pipeline + ( Pipeline, + statement, + ) +where + +import Hasql.Pipeline.Core diff --git a/src/hasql/Hasql/Pipeline/Core.hs b/src/hasql/Hasql/Pipeline/Core.hs new file mode 100644 index 0000000000..11c777965a --- /dev/null +++ b/src/hasql/Hasql/Pipeline/Core.hs @@ -0,0 +1,203 @@ +module Hasql.Pipeline.Core where + +import qualified Hasql.Decoders.All as Decoders +import qualified Hasql.Decoders.Result as Decoders.Result +import qualified Hasql.Decoders.Results as Decoders.Results +import qualified Hasql.Encoders.All as Encoders +import qualified Hasql.Encoders.Params as Encoders.Params +import Hasql.Errors +import qualified Hasql.LibPq14 as Pq +import Hasql.Prelude +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.Statement as Statement + +run :: forall a. Pipeline a -> Bool -> Pq.Connection -> PreparedStatementRegistry.PreparedStatementRegistry -> Bool -> IO (Either SessionError a) +run (Pipeline sendQueriesInIO) usePreparedStatements connection registry integerDatetimes = do + runExceptT do + enterPipelineMode + recvQueries <- sendQueries + pipelineSync + finallyE recvQueries do + recvPipelineSync + exitPipelineMode + where + enterPipelineMode :: ExceptT SessionError IO () + enterPipelineMode = + runCommand $ Pq.enterPipelineMode connection + + exitPipelineMode :: ExceptT SessionError IO () + exitPipelineMode = + runCommand $ Pq.exitPipelineMode connection + + sendQueries :: ExceptT SessionError IO (ExceptT SessionError IO a) + sendQueries = + fmap ExceptT $ ExceptT $ sendQueriesInIO usePreparedStatements connection registry integerDatetimes + + pipelineSync :: ExceptT SessionError IO () + pipelineSync = + runCommand $ Pq.pipelineSync connection + + recvPipelineSync :: ExceptT SessionError IO () + recvPipelineSync = + runResultsDecoder + $ Decoders.Results.single Decoders.Result.pipelineSync + + runResultsDecoder :: forall a. Decoders.Results.Results a -> ExceptT SessionError IO a + runResultsDecoder decoder = + ExceptT (first PipelineError <$> Decoders.Results.run decoder connection integerDatetimes) + + runCommand :: IO Bool -> ExceptT SessionError IO () + runCommand action = + lift action >>= \case + True -> pure () + False -> ExceptT (Left . PipelineError . ClientError <$> Pq.errorMessage connection) + +-- | +-- Composable abstraction over the execution of queries in [the pipeline mode](https://www.postgresql.org/docs/current/libpq-pipeline-mode.html). +-- +-- It allows you to issue multiple queries to the server in much fewer network transactions. +-- If the amounts of sent and received data do not surpass the buffer sizes in the driver and on the server it will be just a single roundtrip. +-- Typically the buffer size is 8KB. +-- +-- This execution mode is much more efficient than running queries directly from 'Hasql.Session.Session', because in session every statement execution involves a dedicated network roundtrip. +-- An obvious question rises then: why not execute all queries like that? +-- +-- In situations where the parameters depend on the result of another query it is impossible to execute them in parallel, because the client needs to receive the results of one query before sending the request to execute the next. +-- This reasoning is essentially the same as the one for the difference between 'Applicative' and 'Monad'. +-- That\'s why 'Pipeline' does not have the 'Monad' instance. +-- +-- To execute 'Pipeline' lift it into 'Hasql.Session.Session' via 'Hasql.Session.pipeline'. +-- +-- == __Examples__ +-- +-- === Insert-Many or Batch-Insert +-- +-- You can use pipeline to turn a single-row insert query into an efficient multi-row insertion session. +-- In effect this should be comparable in performance to issuing a single multi-row insert statement. +-- +-- Given the following definition in a Statements module: +-- +-- @ +-- insertOrder :: 'Hasql.Statement.Statement' OrderDetails OrderId +-- @ +-- +-- You can lift it into the following session +-- +-- @ +-- insertOrders :: [OrderDetails] -> 'Hasql.Session.Session' [OrderId] +-- insertOrders orders = +-- 'Hasql.Session.pipeline' $ +-- for orders $ \\order -> +-- 'Hasql.Pipeline.statement' order Statements.insertOrder +-- @ +-- +-- === Combining Queries +-- +-- Given the following definitions in a Statements module: +-- +-- @ +-- selectOrderDetails :: 'Hasql.Statement.Statement' OrderId (Maybe OrderDetails) +-- selectOrderProducts :: 'Hasql.Statement.Statement' OrderId [OrderProduct] +-- selectOrderFinancialTransactions :: 'Hasql.Statement.Statement' OrderId [FinancialTransaction] +-- @ +-- +-- You can combine them into a session using the `ApplicativeDo` extension as follows: +-- +-- @ +-- selectEverythingAboutOrder :: OrderId -> 'Hasql.Session.Session' (Maybe OrderDetails, [OrderProduct], [FinancialTransaction]) +-- selectEverythingAboutOrder orderId = +-- 'Hasql.Session.pipeline' $ do +-- details <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderDetails +-- products <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderProducts +-- transactions <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderFinancialTransactions +-- pure (details, products, transactions) +-- @ +newtype Pipeline a + = Pipeline + ( Bool -> + Pq.Connection -> + PreparedStatementRegistry.PreparedStatementRegistry -> + Bool -> + IO (Either SessionError (IO (Either SessionError a))) + ) + deriving (Functor) + +instance Applicative Pipeline where + pure a = + Pipeline (\_ _ _ _ -> pure (Right (pure (Right a)))) + + Pipeline lSend <*> Pipeline rSend = + Pipeline \usePreparedStatements conn reg integerDatetimes -> + lSend usePreparedStatements conn reg integerDatetimes >>= \case + Left sendErr -> + pure (Left sendErr) + Right lRecv -> + rSend usePreparedStatements conn reg integerDatetimes <&> \case + Left sendErr -> + Left sendErr + Right rRecv -> + Right (liftA2 (<*>) lRecv rRecv) + +-- | +-- Execute a statement in pipelining mode. +statement :: params -> Statement.Statement params result -> Pipeline result +statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Result decoder) preparable) = + Pipeline run + where + run usePreparedStatements connection registry integerDatetimes = + if usePreparedStatements && preparable + then runPrepared + else runUnprepared + where + runPrepared = runExceptT do + (key, keyRecv) <- ExceptT resolvePreparedStatementKey + queryRecv <- ExceptT (sendQuery key) + pure (keyRecv *> queryRecv) + where + (oidList, valueAndFormatList) = + Encoders.Params.compilePreparedStatementData encoder integerDatetimes params + + resolvePreparedStatementKey = + PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry + where + localKey = + PreparedStatementRegistry.LocalKey sql oidList + onNewRemoteKey key = + do + sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) + if sent + then pure (True, Right (key, recv)) + else (False,) . Left . commandToSessionError . ClientError <$> Pq.errorMessage connection + where + recv = + fmap (first commandToSessionError) + $ (<*) + <$> Decoders.Results.run (Decoders.Results.single Decoders.Result.noResult) connection integerDatetimes + <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes + onOldRemoteKey key = + pure (Right (key, pure (Right ()))) + + sendQuery key = + Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case + False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection + True -> pure (Right recv) + where + recv = + fmap (first commandToSessionError) + $ (<*) + <$> Decoders.Results.run decoder connection integerDatetimes + <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes + + runUnprepared = + Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case + False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection + True -> pure (Right recv) + where + recv = + fmap (first commandToSessionError) + $ (<*) + <$> Decoders.Results.run decoder connection integerDatetimes + <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes + + commandToSessionError = + QueryError sql (Encoders.Params.renderReadable encoder params) diff --git a/src/hasql/Hasql/Pool.hs b/src/hasql/Hasql/Pool.hs new file mode 100644 index 0000000000..84acfb27fe --- /dev/null +++ b/src/hasql/Hasql/Pool.hs @@ -0,0 +1,254 @@ +module Hasql.Pool + ( -- * Pool + Pool, + acquire, + use, + release, + + -- * Errors + UsageError (..), + ) +where + +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.UUID.V4 as Uuid +import Hasql.Connection (Connection) +import qualified Hasql.Connection as Connection +import qualified Hasql.Connection.Setting as Connection.Setting +import qualified Hasql.Pool.Config.Config as Config +import Hasql.Pool.Observation +import Hasql.Pool.Prelude +import qualified Hasql.Pool.SessionErrorDestructors as ErrorsDestruction +import qualified Hasql.Session as Session + +-- | A connection tagged with metadata. +data Entry = Entry + { entryConnection :: Connection, + entryCreationTimeNSec :: Word64, + entryUseTimeNSec :: Word64, + entryId :: UUID + } + +entryIsAged :: Word64 -> Word64 -> Entry -> Bool +entryIsAged maxLifetime now Entry {..} = + now > entryCreationTimeNSec + maxLifetime + +entryIsIdle :: Word64 -> Word64 -> Entry -> Bool +entryIsIdle maxIdletime now Entry {..} = + now > entryUseTimeNSec + maxIdletime + +-- | Pool of connections to DB. +data Pool = Pool + { -- | Pool size. + poolSize :: Int, + -- | Connection settings. + poolFetchConnectionSettings :: IO [Connection.Setting.Setting], + -- | Acquisition timeout, in microseconds. + poolAcquisitionTimeout :: Int, + -- | Maximal connection lifetime, in nanoseconds. + poolMaxLifetime :: Word64, + -- | Maximal connection idle time, in nanoseconds. + poolMaxIdletime :: Word64, + -- | Avail connections. + poolConnectionQueue :: TQueue Entry, + -- | Remaining capacity. + -- The pool size limits the sum of poolCapacity, the length + -- of poolConnectionQueue and the number of in-flight + -- connections. + poolCapacity :: TVar Int, + -- | Whether to return a connection to the pool. + poolReuseVar :: TVar (TVar Bool), + -- | To stop the manager thread via garbage collection. + poolReaperRef :: IORef (), + -- | Action for reporting the observations. + poolObserver :: Observation -> IO (), + -- | Initial session to execute upon every established connection. + poolInitSession :: Session.Session () + } + +-- | Create a connection-pool. +-- +-- No connections actually get established by this function. It is delegated +-- to 'use'. +-- +-- If you want to ensure that the pool connects fine at the initialization phase, just run 'use' with an empty session (@pure ()@) and check for errors. +acquire :: Config.Config -> IO Pool +acquire config = do + connectionQueue <- newTQueueIO + capVar <- newTVarIO (Config.size config) + reuseVar <- newTVarIO =<< newTVarIO True + reaperRef <- newIORef () + + managerTid <- forkIOWithUnmask $ \unmask -> unmask $ forever $ do + threadDelay 1000000 + now <- getMonotonicTimeNSec + join . atomically $ do + entries <- flushTQueue connectionQueue + let (agedEntries, unagedEntries) = partition (entryIsAged agingTimeoutNanos now) entries + (idleEntries, liveEntries) = partition (entryIsIdle agingTimeoutNanos now) unagedEntries + traverse_ (writeTQueue connectionQueue) liveEntries + return $ do + forM_ agedEntries $ \entry -> do + Connection.release (entryConnection entry) + atomically $ modifyTVar' capVar succ + Config.observationHandler config (ConnectionObservation (entryId entry) (TerminatedConnectionStatus AgingConnectionTerminationReason)) + forM_ idleEntries $ \entry -> do + Connection.release (entryConnection entry) + atomically $ modifyTVar' capVar succ + Config.observationHandler config (ConnectionObservation (entryId entry) (TerminatedConnectionStatus IdlenessConnectionTerminationReason)) + + void . mkWeakIORef reaperRef $ do + -- When the pool goes out of scope, stop the manager. + killThread managerTid + + return $ Pool (Config.size config) (Config.connectionSettingsProvider config) acqTimeoutMicros agingTimeoutNanos maxIdletimeNanos connectionQueue capVar reuseVar reaperRef (Config.observationHandler config) (Config.initSession config) + where + acqTimeoutMicros = + div (fromIntegral (diffTimeToPicoseconds (Config.acquisitionTimeout config))) 1_000_000 + agingTimeoutNanos = + div (fromIntegral (diffTimeToPicoseconds (Config.agingTimeout config))) 1_000 + maxIdletimeNanos = + div (fromIntegral (diffTimeToPicoseconds (Config.idlenessTimeout config))) 1_000 + +-- | Release all the idle connections in the pool, and mark the in-use connections +-- to be released after use. Any connections acquired after the call will be +-- freshly established. +-- +-- The pool remains usable after this action. +-- So you can use this function to reset the connections in the pool. +-- Naturally, you can also use it to release the resources. +release :: Pool -> IO () +release Pool {..} = + join . atomically $ do + prevReuse <- readTVar poolReuseVar + writeTVar prevReuse False + newReuse <- newTVar True + writeTVar poolReuseVar newReuse + entries <- flushTQueue poolConnectionQueue + return $ forM_ entries $ \entry -> do + Connection.release (entryConnection entry) + atomically $ modifyTVar' poolCapacity succ + poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus ReleaseConnectionTerminationReason)) + +-- | Use a connection from the pool to run a session and return the connection +-- to the pool, when finished. +-- +-- Session failing with a 'Session.ClientError' gets interpreted as a loss of +-- connection. In such case the connection does not get returned to the pool +-- and a slot gets freed up for a new connection to be established the next +-- time one is needed. The error still gets returned from this function. +-- +-- __Warning:__ Due to the mechanism mentioned above you should avoid intercepting this error type from within sessions. +use :: Pool -> Session.Session a -> IO (Either UsageError a) +use Pool {..} sess = do + timeout <- do + delay <- registerDelay poolAcquisitionTimeout + return $ readTVar delay + join . atomically $ do + reuseVar <- readTVar poolReuseVar + asum + [ readTQueue poolConnectionQueue <&> onConn reuseVar, + do + capVal <- readTVar poolCapacity + if capVal > 0 + then do + writeTVar poolCapacity $! pred capVal + return $ onNewConn reuseVar + else retry, + do + timedOut <- timeout + if timedOut + then return . return . Left $ AcquisitionTimeoutUsageError + else retry + ] + where + onNewConn reuseVar = do + settings <- poolFetchConnectionSettings + now <- getMonotonicTimeNSec + id <- Uuid.nextRandom + poolObserver (ConnectionObservation id ConnectingConnectionStatus) + Connection.acquire settings >>= \case + Left connErr -> do + poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) connErr)))) + atomically $ modifyTVar' poolCapacity succ + return $ Left $ ConnectionUsageError connErr + Right connection -> do + Session.run poolInitSession connection >>= \case + Left err -> do + Connection.release connection + ErrorsDestruction.reset + ( \details -> do + poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) details)))) + ) + (poolObserver (ConnectionObservation id (TerminatedConnectionStatus (InitializationErrorTerminationReason err)))) + err + return $ Left $ SessionUsageError err + Right () -> do + poolObserver (ConnectionObservation id (ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason)) + onLiveConn reuseVar (Entry connection now now id) + + onConn reuseVar entry = do + now <- getMonotonicTimeNSec + if entryIsAged poolMaxLifetime now entry + then do + Connection.release (entryConnection entry) + poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus AgingConnectionTerminationReason)) + onNewConn reuseVar + else + if entryIsIdle poolMaxIdletime now entry + then do + Connection.release (entryConnection entry) + poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus IdlenessConnectionTerminationReason)) + onNewConn reuseVar + else do + onLiveConn reuseVar entry {entryUseTimeNSec = now} + + onLiveConn reuseVar entry = do + poolObserver (ConnectionObservation (entryId entry) InUseConnectionStatus) + sessRes <- try @SomeException (Session.run sess (entryConnection entry)) + + case sessRes of + Left exc -> do + returnConn + throwIO exc + Right (Left err) -> + ErrorsDestruction.reset + ( \details -> do + Connection.release (entryConnection entry) + atomically $ modifyTVar' poolCapacity succ + poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) details)))) + return $ Left $ SessionUsageError err + ) + ( do + returnConn + poolObserver (ConnectionObservation (entryId entry) (ReadyForUseConnectionStatus (SessionFailedConnectionReadyForUseReason err))) + return $ Left $ SessionUsageError err + ) + err + Right (Right res) -> do + returnConn + poolObserver (ConnectionObservation (entryId entry) (ReadyForUseConnectionStatus SessionSucceededConnectionReadyForUseReason)) + return $ Right res + where + returnConn = + join . atomically $ do + reuse <- readTVar reuseVar + if reuse + then writeTQueue poolConnectionQueue entry $> return () + else return $ do + Connection.release (entryConnection entry) + atomically $ modifyTVar' poolCapacity succ + poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus ReleaseConnectionTerminationReason)) + +-- | Union over all errors that 'use' can result in. +data UsageError + = -- | Attempt to establish a connection failed. + ConnectionUsageError Connection.ConnectionError + | -- | Session execution failed. + SessionUsageError Session.SessionError + | -- | Timeout acquiring a connection. + AcquisitionTimeoutUsageError + deriving (Show, Eq) + +instance Exception UsageError diff --git a/src/hasql/Hasql/Pool/Config.hs b/src/hasql/Hasql/Pool/Config.hs new file mode 100644 index 0000000000..90e6686ec1 --- /dev/null +++ b/src/hasql/Hasql/Pool/Config.hs @@ -0,0 +1,25 @@ +-- | DSL for construction of configs. +module Hasql.Pool.Config + ( Config.Config, + settings, + Setting.Setting, + Setting.size, + Setting.acquisitionTimeout, + Setting.agingTimeout, + Setting.idlenessTimeout, + Setting.staticConnectionSettings, + Setting.dynamicConnectionSettings, + Setting.observationHandler, + Setting.initSession, + ) +where + +import qualified Hasql.Pool.Config.Config as Config +import qualified Hasql.Pool.Config.Setting as Setting +import Hasql.Pool.Prelude + +-- | Compile config from a list of settings. +-- Latter settings override the preceding in cases of conflicts. +settings :: [Setting.Setting] -> Config.Config +settings = + foldr Setting.apply Config.defaults diff --git a/src/hasql/Hasql/Pool/Config/Config.hs b/src/hasql/Hasql/Pool/Config/Config.hs new file mode 100644 index 0000000000..30fa97a8c9 --- /dev/null +++ b/src/hasql/Hasql/Pool/Config/Config.hs @@ -0,0 +1,31 @@ +module Hasql.Pool.Config.Config where + +import qualified Hasql.Connection.Setting as Connection.Setting +import qualified Hasql.Pool.Config.Defaults as Defaults +import Hasql.Pool.Observation (Observation) +import Hasql.Pool.Prelude +import qualified Hasql.Session as Session + +-- | Configuration for Hasql connection pool. +data Config = Config + { size :: Int, + acquisitionTimeout :: DiffTime, + agingTimeout :: DiffTime, + idlenessTimeout :: DiffTime, + connectionSettingsProvider :: IO [Connection.Setting.Setting], + observationHandler :: Observation -> IO (), + initSession :: Session.Session () + } + +-- | Reasonable defaults, which can be built upon. +defaults :: Config +defaults = + Config + { size = Defaults.size, + acquisitionTimeout = Defaults.acquisitionTimeout, + agingTimeout = Defaults.agingTimeout, + idlenessTimeout = Defaults.idlenessTimeout, + connectionSettingsProvider = Defaults.dynamicConnectionSettings, + observationHandler = Defaults.observationHandler, + initSession = Defaults.initSession + } diff --git a/src/hasql/Hasql/Pool/Config/Defaults.hs b/src/hasql/Hasql/Pool/Config/Defaults.hs new file mode 100644 index 0000000000..09bf3506a2 --- /dev/null +++ b/src/hasql/Hasql/Pool/Config/Defaults.hs @@ -0,0 +1,49 @@ +module Hasql.Pool.Config.Defaults where + +import qualified Hasql.Connection.Setting as Connection.Setting +import qualified Hasql.Connection.Setting.Connection as Connection.Setting.Connection +import Hasql.Pool.Observation (Observation) +import Hasql.Pool.Prelude +import qualified Hasql.Session as Session + +-- | +-- 3 connections. +size :: Int +size = 3 + +-- | +-- 10 seconds. +acquisitionTimeout :: DiffTime +acquisitionTimeout = 10 + +-- | +-- 1 day. +agingTimeout :: DiffTime +agingTimeout = 60 * 60 * 24 + +-- | +-- 10 minutes. +idlenessTimeout :: DiffTime +idlenessTimeout = 60 * 10 + +-- | +-- > "postgresql://postgres:postgres@localhost:5432/postgres" +staticConnectionSettings :: [Connection.Setting.Setting] +staticConnectionSettings = + [ Connection.Setting.connection (Connection.Setting.Connection.string "postgresql://postgres:postgres@localhost:5432/postgres") + ] + +-- | +-- > pure "postgresql://postgres:postgres@localhost:5432/postgres" +dynamicConnectionSettings :: IO [Connection.Setting.Setting] +dynamicConnectionSettings = pure staticConnectionSettings + +-- | +-- > const (pure ()) +observationHandler :: Observation -> IO () +observationHandler = const (pure ()) + +-- | +-- > pure () +initSession :: Session.Session () +initSession = pure () diff --git a/src/hasql/Hasql/Pool/Config/Setting.hs b/src/hasql/Hasql/Pool/Config/Setting.hs new file mode 100644 index 0000000000..0d9e561cac --- /dev/null +++ b/src/hasql/Hasql/Pool/Config/Setting.hs @@ -0,0 +1,93 @@ +module Hasql.Pool.Config.Setting where + +import qualified Hasql.Connection.Setting as Connection.Setting +import Hasql.Pool.Config.Config (Config) +import qualified Hasql.Pool.Config.Config as Config +import Hasql.Pool.Observation (Observation) +import Hasql.Pool.Prelude +import qualified Hasql.Session as Session + +apply :: Setting -> Config -> Config +apply (Setting run) = run + +-- | A single setting of a config. +newtype Setting + = Setting (Config -> Config) + +-- | Pool size. +-- +-- 3 by default. +size :: Int -> Setting +size x = + Setting (\config -> config {Config.size = x}) + +-- | Connection acquisition timeout. +-- +-- 10 seconds by default. +acquisitionTimeout :: DiffTime -> Setting +acquisitionTimeout x = + Setting (\config -> config {Config.acquisitionTimeout = x}) + +-- | Maximal connection lifetime. +-- +-- Determines how long is available for reuse. +-- After the timeout passes and an active session is finished the connection will be closed releasing a slot in the pool for a fresh connection to be established. +-- +-- This is useful as a healthy measure for resetting the server-side caches. +-- +-- 1 day by default. +agingTimeout :: DiffTime -> Setting +agingTimeout x = + Setting (\config -> config {Config.agingTimeout = x}) + +-- | Maximal connection idle time. +-- +-- How long to keep a connection open when it's not being used. +-- +-- 10 minutes by default. +idlenessTimeout :: DiffTime -> Setting +idlenessTimeout x = + Setting (\config -> config {Config.idlenessTimeout = x}) + +-- | Connection string. +-- +-- By default it is: +-- +-- > "postgresql://postgres:postgres@localhost:5432/postgres" +staticConnectionSettings :: [Connection.Setting.Setting] -> Setting +staticConnectionSettings x = + Setting (\config -> config {Config.connectionSettingsProvider = pure x}) + +-- | Action providing connection settings. +-- +-- Gets used each time a connection gets established by the pool. +-- This may be useful for some authorization models. +-- +-- By default it is: +-- +-- > pure "postgresql://postgres:postgres@localhost:5432/postgres" +dynamicConnectionSettings :: IO [Connection.Setting.Setting] -> Setting +dynamicConnectionSettings x = + Setting (\config -> config {Config.connectionSettingsProvider = x}) + +-- | Observation handler. +-- +-- Typically it's used for monitoring the state of the pool via metrics and logging. +-- +-- If the provided action is not lightweight, it's recommended to use intermediate bufferring via channels like TBQueue to avoid occupying the pool management thread for too long. +-- E.g., if the action is @'atomically' . 'writeTBQueue' yourQueue@, then reading from it and processing can be done on a separate thread. +-- +-- By default it is: +-- +-- > const (pure ()) +observationHandler :: (Observation -> IO ()) -> Setting +observationHandler x = + Setting (\config -> config {Config.observationHandler = x}) + +-- | Initial session. +-- +-- Gets executed on every connection upon acquisition. +-- Lets you specify the connection-wide settings. +initSession :: Session.Session () -> Setting +initSession x = + Setting (\config -> config {Config.initSession = x}) diff --git a/src/hasql/Hasql/Pool/Observation.hs b/src/hasql/Hasql/Pool/Observation.hs new file mode 100644 index 0000000000..8bfab7720e --- /dev/null +++ b/src/hasql/Hasql/Pool/Observation.hs @@ -0,0 +1,60 @@ +-- | Interface for processing observations of the status of the pool. +-- +-- Provides a flexible mechanism for monitoring the healthiness of the pool via logs and metrics without any opinionated choices on the actual monitoring technologies. +-- Specific interpreters are encouraged to be created as extension libraries. +module Hasql.Pool.Observation where + +import Hasql.Pool.Prelude +import qualified Hasql.Session as Session + +-- | An observation of a change of the state of a pool. +data Observation + = -- | Status of one of the pool's connections has changed. + ConnectionObservation + -- | Generated connection ID. + -- For grouping the observations by one connection. + UUID + -- | Status that the connection has entered. + ConnectionStatus + deriving (Show, Eq) + +-- | Status of a connection. +-- +-- <> +data ConnectionStatus + = -- | Connection is being established. + -- + -- This is the initial status of every connection. + ConnectingConnectionStatus + | -- | Connection is established and not occupied. + ReadyForUseConnectionStatus ConnectionReadyForUseReason + | -- | Is being used by some session. + -- + -- After it's done the status will transition to 'ReadyForUseConnectionStatus' or 'TerminatedConnectionStatus'. + InUseConnectionStatus + | -- | Connection terminated. + TerminatedConnectionStatus ConnectionTerminationReason + deriving (Show, Eq) + +data ConnectionReadyForUseReason + = -- | Connection just got established. + EstablishedConnectionReadyForUseReason + | -- | Session execution ended with a failure that does not require a connection reset. + SessionFailedConnectionReadyForUseReason Session.SessionError + | -- | Session execution ended with success. + SessionSucceededConnectionReadyForUseReason + deriving (Show, Eq) + +-- | Explanation of why a connection was terminated. +data ConnectionTerminationReason + = -- | The age timeout of the connection has passed. + AgingConnectionTerminationReason + | -- | The timeout of how long a connection may remain idle in the pool has passed. + IdlenessConnectionTerminationReason + | -- | Connectivity issues with the server. + NetworkErrorConnectionTerminationReason (Maybe Text) + | -- | User has invoked the 'Hasql.Pool.release' procedure. + ReleaseConnectionTerminationReason + | -- | Initialization session failure. + InitializationErrorTerminationReason Session.SessionError + deriving (Show, Eq) diff --git a/src/hasql/Hasql/Pool/Prelude.hs b/src/hasql/Hasql/Pool/Prelude.hs new file mode 100644 index 0000000000..2d8c7d4117 --- /dev/null +++ b/src/hasql/Hasql/Pool/Prelude.hs @@ -0,0 +1,99 @@ +module Hasql.Pool.Prelude + ( module Exports, + ) +where + +import Control.Applicative as Exports hiding (WrappedArrow (..)) +import Control.Arrow as Exports hiding (first, second) +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Concurrent.STM as Exports hiding (orElse) +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, forM, forM_, + mapM, mapM_, msum, sequence, + sequence_) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Data.Bifunctor as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Compose as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, + concat, concatMap, elem, + find, foldl, foldl', foldl1, + foldr, foldr1, + isSubsequenceOf, mapAccumL, + mapAccumR, maximum, + maximumBy, minimum, + minimumBy, notElem, or, + product, sortOn, sum, + uncons) +import Data.List.NonEmpty as Exports (NonEmpty (..)) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (Alt) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.String as Exports +import Data.Text as Exports (Text) +import Data.Time as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.UUID as Exports (UUID) +import Data.Version as Exports +import Data.Void as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports +import GHC.Clock as Exports (getMonotonicTimeNSec) +import GHC.Conc as Exports hiding (orElse, + threadWaitRead, + threadWaitReadSTM, + threadWaitWrite, + threadWaitWriteSTM, + withMVar) +import GHC.Exts as Exports (IsList (..), groupWith, + inline, lazy, sortWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (all, and, any, + concat, concatMap, elem, + fail, foldl, foldl1, foldr, + foldr1, id, mapM, mapM_, + maximum, minimum, notElem, + or, product, sequence, + sequence_, sum, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports (Handle, hClose) +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, + readMaybe) +import Unsafe.Coerce as Exports diff --git a/src/hasql/Hasql/Pool/SessionErrorDestructors.hs b/src/hasql/Hasql/Pool/SessionErrorDestructors.hs new file mode 100644 index 0000000000..272b980fdb --- /dev/null +++ b/src/hasql/Hasql/Pool/SessionErrorDestructors.hs @@ -0,0 +1,10 @@ +module Hasql.Pool.SessionErrorDestructors where + +import Hasql.Pool.Prelude +import qualified Hasql.Session as Session + +reset :: (Maybe ByteString -> x) -> x -> Session.SessionError -> x +reset onReset onNoReset = \case + Session.QueryError _ _ (Session.ClientError details) -> onReset details + Session.PipelineError (Session.ClientError details) -> onReset details + _ -> onNoReset diff --git a/src/hasql/Hasql/PostgresTypeInfo.hs b/src/hasql/Hasql/PostgresTypeInfo.hs new file mode 100644 index 0000000000..e8e3e540d9 --- /dev/null +++ b/src/hasql/Hasql/PostgresTypeInfo.hs @@ -0,0 +1,250 @@ +module Hasql.PostgresTypeInfo where + +import qualified Hasql.LibPq14 as LibPQ +import Hasql.Prelude hiding (bool) + +-- | 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, oidFormat :: !LibPQ.Format} + +mkOID :: LibPQ.Format -> Word32 -> OID +mkOID format x = + OID x ((LibPQ.Oid . fromIntegral) x) format + +mkPTI :: LibPQ.Format -> Word32 -> Maybe Word32 -> PTI +mkPTI format oid arrayOID = + PTI (mkOID format oid) (fmap (mkOID format) arrayOID) + +-- * Constants + +abstime :: PTI +abstime = mkPTI LibPQ.Binary 702 (Just 1023) + +aclitem :: PTI +aclitem = mkPTI LibPQ.Binary 1033 (Just 1034) + +bit :: PTI +bit = mkPTI LibPQ.Binary 1560 (Just 1561) + +bool :: PTI +bool = mkPTI LibPQ.Binary 16 (Just 1000) + +box :: PTI +box = mkPTI LibPQ.Binary 603 (Just 1020) + +bpchar :: PTI +bpchar = mkPTI LibPQ.Binary 1042 (Just 1014) + +bytea :: PTI +bytea = mkPTI LibPQ.Binary 17 (Just 1001) + +char :: PTI +char = mkPTI LibPQ.Binary 18 (Just 1002) + +cid :: PTI +cid = mkPTI LibPQ.Binary 29 (Just 1012) + +cidr :: PTI +cidr = mkPTI LibPQ.Binary 650 (Just 651) + +circle :: PTI +circle = mkPTI LibPQ.Binary 718 (Just 719) + +cstring :: PTI +cstring = mkPTI LibPQ.Binary 2275 (Just 1263) + +date :: PTI +date = mkPTI LibPQ.Binary 1082 (Just 1182) + +daterange :: PTI +daterange = mkPTI LibPQ.Binary 3912 (Just 3913) + +datemultirange :: PTI +datemultirange = mkPTI LibPQ.Binary 4535 (Just 6155) + +float4 :: PTI +float4 = mkPTI LibPQ.Binary 700 (Just 1021) + +float8 :: PTI +float8 = mkPTI LibPQ.Binary 701 (Just 1022) + +gtsvector :: PTI +gtsvector = mkPTI LibPQ.Binary 3642 (Just 3644) + +inet :: PTI +inet = mkPTI LibPQ.Binary 869 (Just 1041) + +int2 :: PTI +int2 = mkPTI LibPQ.Binary 21 (Just 1005) + +int2vector :: PTI +int2vector = mkPTI LibPQ.Binary 22 (Just 1006) + +int4 :: PTI +int4 = mkPTI LibPQ.Binary 23 (Just 1007) + +int4range :: PTI +int4range = mkPTI LibPQ.Binary 3904 (Just 3905) + +int4multirange :: PTI +int4multirange = mkPTI LibPQ.Binary 4451 (Just 6150) + +int8 :: PTI +int8 = mkPTI LibPQ.Binary 20 (Just 1016) + +int8range :: PTI +int8range = mkPTI LibPQ.Binary 3926 (Just 3927) + +int8multirange :: PTI +int8multirange = mkPTI LibPQ.Binary 4536 (Just 6157) + +interval :: PTI +interval = mkPTI LibPQ.Binary 1186 (Just 1187) + +json :: PTI +json = mkPTI LibPQ.Binary 114 (Just 199) + +jsonb :: PTI +jsonb = mkPTI LibPQ.Binary 3802 (Just 3807) + +line :: PTI +line = mkPTI LibPQ.Binary 628 (Just 629) + +lseg :: PTI +lseg = mkPTI LibPQ.Binary 601 (Just 1018) + +macaddr :: PTI +macaddr = mkPTI LibPQ.Binary 829 (Just 1040) + +money :: PTI +money = mkPTI LibPQ.Binary 790 (Just 791) + +name :: PTI +name = mkPTI LibPQ.Binary 19 (Just 1003) + +numeric :: PTI +numeric = mkPTI LibPQ.Binary 1700 (Just 1231) + +numrange :: PTI +numrange = mkPTI LibPQ.Binary 3906 (Just 3907) + +nummultirange :: PTI +nummultirange = mkPTI LibPQ.Binary 4532 (Just 6151) + +oid :: PTI +oid = mkPTI LibPQ.Binary 26 (Just 1028) + +oidvector :: PTI +oidvector = mkPTI LibPQ.Binary 30 (Just 1013) + +path :: PTI +path = mkPTI LibPQ.Binary 602 (Just 1019) + +point :: PTI +point = mkPTI LibPQ.Binary 600 (Just 1017) + +polygon :: PTI +polygon = mkPTI LibPQ.Binary 604 (Just 1027) + +record :: PTI +record = mkPTI LibPQ.Binary 2249 (Just 2287) + +refcursor :: PTI +refcursor = mkPTI LibPQ.Binary 1790 (Just 2201) + +regclass :: PTI +regclass = mkPTI LibPQ.Binary 2205 (Just 2210) + +regconfig :: PTI +regconfig = mkPTI LibPQ.Binary 3734 (Just 3735) + +regdictionary :: PTI +regdictionary = mkPTI LibPQ.Binary 3769 (Just 3770) + +regoper :: PTI +regoper = mkPTI LibPQ.Binary 2203 (Just 2208) + +regoperator :: PTI +regoperator = mkPTI LibPQ.Binary 2204 (Just 2209) + +regproc :: PTI +regproc = mkPTI LibPQ.Binary 24 (Just 1008) + +regprocedure :: PTI +regprocedure = mkPTI LibPQ.Binary 2202 (Just 2207) + +regtype :: PTI +regtype = mkPTI LibPQ.Binary 2206 (Just 2211) + +reltime :: PTI +reltime = mkPTI LibPQ.Binary 703 (Just 1024) + +text :: PTI +text = mkPTI LibPQ.Binary 25 (Just 1009) + +tid :: PTI +tid = mkPTI LibPQ.Binary 27 (Just 1010) + +time :: PTI +time = mkPTI LibPQ.Binary 1083 (Just 1183) + +timestamp :: PTI +timestamp = mkPTI LibPQ.Binary 1114 (Just 1115) + +timestamptz :: PTI +timestamptz = mkPTI LibPQ.Binary 1184 (Just 1185) + +timetz :: PTI +timetz = mkPTI LibPQ.Binary 1266 (Just 1270) + +tinterval :: PTI +tinterval = mkPTI LibPQ.Binary 704 (Just 1025) + +tsquery :: PTI +tsquery = mkPTI LibPQ.Binary 3615 (Just 3645) + +tsrange :: PTI +tsrange = mkPTI LibPQ.Binary 3908 (Just 3909) + +tsmultirange :: PTI +tsmultirange = mkPTI LibPQ.Binary 4533 (Just 6152) + +tstzrange :: PTI +tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911) + +tstzmultirange :: PTI +tstzmultirange = mkPTI LibPQ.Binary 4534 (Just 6153) + +tsvector :: PTI +tsvector = mkPTI LibPQ.Binary 3614 (Just 3643) + +-- txid_snapshot is the name of a PostgreSQL type, so snake case is correct. +{- HLINT ignore txid_snapshot "Use camelCase" -} +txid_snapshot :: PTI +txid_snapshot = mkPTI LibPQ.Binary 2970 (Just 2949) + +textUnknown :: PTI +textUnknown = mkPTI LibPQ.Text 705 (Just 705) + +binaryUnknown :: PTI +binaryUnknown = mkPTI LibPQ.Binary 705 (Just 705) + +uuid :: PTI +uuid = mkPTI LibPQ.Binary 2950 (Just 2951) + +varbit :: PTI +varbit = mkPTI LibPQ.Binary 1562 (Just 1563) + +varchar :: PTI +varchar = mkPTI LibPQ.Binary 1043 (Just 1015) + +void :: PTI +void = mkPTI LibPQ.Binary 2278 Nothing + +xid :: PTI +xid = mkPTI LibPQ.Binary 28 (Just 1011) + +xml :: PTI +xml = mkPTI LibPQ.Binary 142 (Just 143) diff --git a/src/hasql/Hasql/Prelude.hs b/src/hasql/Hasql/Prelude.hs new file mode 100644 index 0000000000..529c71fa59 --- /dev/null +++ b/src/hasql/Hasql/Prelude.hs @@ -0,0 +1,260 @@ +module Hasql.Prelude + ( module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + forMToZero_, + forMFromZero_, + strictCons, + ) +where + +import Control.Applicative as Exports hiding + (WrappedArrow (..)) +import Control.Arrow as Exports hiding + (first, + second) +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding + (fail, + forM, + forM_, + mapM, + mapM_, + msum, + sequence, + sequence_) +import Control.Monad.Error.Class as Exports (MonadError (..)) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding + (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.Reader.Class as Exports (MonadReader (..)) +import Control.Monad.ST as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Cont as Exports hiding + (callCC, + shift) +import Control.Monad.Trans.Except as Exports (Except, + ExceptT (ExceptT), + catchE, + except, + finallyE, + mapExcept, + mapExceptT, + runExcept, + runExceptT, + throwE, + withExcept, + withExceptT) +import Control.Monad.Trans.Maybe as Exports +import Control.Monad.Trans.Reader as Exports (Reader, + ReaderT (ReaderT), + mapReader, + mapReaderT, + runReader, + runReaderT, + withReader, + withReaderT) +import Control.Monad.Trans.State.Strict as Exports (State, + StateT (StateT), + evalState, + evalStateT, + execState, + execStateT, + mapState, + mapStateT, + runState, + runStateT, + withState, + withStateT) +import Control.Monad.Trans.Writer.Strict as Exports (Writer, + WriterT (..), + execWriter, + execWriterT, + mapWriter, + mapWriterT, + runWriter) +import Data.Bifunctor as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import qualified Data.ByteString.Builder +import qualified Data.ByteString.Lazy +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.DList as Exports (DList) +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding + (toList) +import Data.Function as Exports hiding + (id, + (.)) +import Data.Functor as Exports hiding + (unzip) +import Data.Functor.Compose as Exports +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports +import Data.Functor.Identity as Exports +import Data.Hashable as Exports (Hashable (..)) +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding + (all, + and, + any, + concat, + concatMap, + elem, + filter, + find, + foldl, + foldl', + foldl1, + foldr, + foldr1, + isSubsequenceOf, + mapAccumL, + mapAccumR, + maximum, + maximumBy, + minimum, + minimumBy, + notElem, + or, + product, + sortOn, + sum, + uncons) +import Data.List.NonEmpty as Exports (NonEmpty (..)) +import Data.Maybe as Exports hiding + (catMaybes, + mapMaybe) +import Data.Monoid as Exports hiding + (Alt, + (<>)) +import Data.Ord as Exports +import Data.Profunctor.Unsafe as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Scientific as Exports (Scientific) +import Data.Semigroup as Exports hiding + (First (..), + Last (..)) +import Data.STRef as Exports +import Data.String as Exports +import Data.Text as Exports (Text) +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import Data.Time as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.UUID as Exports (UUID) +import Data.Vector as Exports (Vector) +import Data.Version as Exports +import Data.Void as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports +import GHC.Conc as Exports hiding + (orElse, + threadWaitRead, + threadWaitReadSTM, + threadWaitWrite, + threadWaitWriteSTM, + withMVar) +import GHC.Exts as Exports (IsList (..), + groupWith, + inline, + lazy, + sortWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import GHC.OverloadedLabels as Exports +import Numeric as Exports +import Prelude as Exports hiding + (Read, + all, + and, + any, + concat, + concatMap, + elem, + fail, + filter, + foldl, + foldl1, + foldr, + foldr1, + id, + mapM, + mapM_, + maximum, + minimum, + notElem, + or, + product, + sequence, + sequence_, + sum, + (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports (Handle, + hClose) +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.ParserCombinators.ReadP as Exports (ReadP, + readP_to_S, + readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, + readP_to_Prec, + readPrec_to_P, + readPrec_to_S, + readS_to_Prec) +import Text.Printf as Exports (hPrintf, + printf) +import Unsafe.Coerce as Exports +import Witherable as Exports + +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 + +{-# INLINE forMToZero_ #-} +forMToZero_ :: (Applicative m) => Int -> (Int -> m a) -> m () +forMToZero_ !startN f = + ($ pred startN) $ fix $ \loop !n -> when (n >= 0) $ f n *> loop (pred n) + +{-# INLINE forMFromZero_ #-} +forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m () +forMFromZero_ !endN f = + ($ 0) $ fix $ \loop !n -> when (n < endN) $ f n *> loop (succ n) + +{-# INLINE strictCons #-} +strictCons :: a -> [a] -> [a] +strictCons !a b = + let !c = a : b in c diff --git a/src/hasql/Hasql/PreparedStatementRegistry.hs b/src/hasql/Hasql/PreparedStatementRegistry.hs new file mode 100644 index 0000000000..905b7facbf --- /dev/null +++ b/src/hasql/Hasql/PreparedStatementRegistry.hs @@ -0,0 +1,64 @@ +module Hasql.PreparedStatementRegistry + ( PreparedStatementRegistry, + new, + update, + reset, + LocalKey (..), + ) +where + +import qualified ByteString.StrictBuilder as B +import qualified Data.HashTable.IO as A +import qualified Hasql.LibPq14 as Pq +import Hasql.Prelude hiding (lookup, reset) + +data PreparedStatementRegistry + = PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word) + +{-# INLINEABLE new #-} +new :: IO PreparedStatementRegistry +new = + PreparedStatementRegistry <$> A.new <*> newIORef 0 + +{-# INLINEABLE update #-} +update :: LocalKey -> (ByteString -> IO (Bool, a)) -> (ByteString -> IO a) -> PreparedStatementRegistry -> IO a +update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table counter) = + lookup >>= maybe new old + where + lookup = + A.lookup table localKey + new = + readIORef counter >>= onN + where + onN n = + do + (save, result) <- onNewRemoteKey remoteKey + when save $ do + A.insert table localKey remoteKey + writeIORef counter (succ n) + return result + where + remoteKey = + B.builderBytes . B.asciiIntegral $ n + old = + onOldRemoteKey + +reset :: PreparedStatementRegistry -> IO () +reset (PreparedStatementRegistry table counter) = do + -- TODO: This is a temporary measure. + -- We should just move to a pure implementation. + do + entries <- A.toList table + forM_ entries \(k, _) -> A.delete table k + writeIORef counter 0 + +-- | +-- Local statement key. +data LocalKey + = LocalKey !ByteString ![Pq.Oid] + deriving (Show, Eq) + +instance Hashable LocalKey where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (LocalKey template _) = + hashWithSalt salt template diff --git a/src/hasql/Hasql/Session.hs b/src/hasql/Hasql/Session.hs new file mode 100644 index 0000000000..79690235d8 --- /dev/null +++ b/src/hasql/Hasql/Session.hs @@ -0,0 +1,16 @@ +module Hasql.Session + ( Session, + sql, + statement, + pipeline, + + -- * Execution + run, + + -- * Errors + module Hasql.Errors, + ) +where + +import Hasql.Errors +import Hasql.Session.Core diff --git a/src/hasql/Hasql/Session/Core.hs b/src/hasql/Hasql/Session/Core.hs new file mode 100644 index 0000000000..614b99d3ab --- /dev/null +++ b/src/hasql/Hasql/Session/Core.hs @@ -0,0 +1,82 @@ +module Hasql.Session.Core where + +import qualified Hasql.Connection.Core as Connection +import qualified Hasql.Decoders.All as Decoders +import qualified Hasql.Decoders.Result as Decoders.Result +import qualified Hasql.Decoders.Results as Decoders.Results +import qualified Hasql.Encoders.All as Encoders +import qualified Hasql.Encoders.Params as Encoders.Params +import Hasql.Errors +import qualified Hasql.IO as IO +import qualified Hasql.LibPq14 as Pq +import qualified Hasql.Pipeline.Core as Pipeline +import Hasql.Prelude +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.Statement as Statement + +-- | +-- A batch of actions to be executed in the context of a database connection. +newtype Session a + = Session (ReaderT Connection.Connection (ExceptT SessionError IO) a) + deriving (Functor, Applicative, Monad, MonadError SessionError, MonadIO, MonadReader Connection.Connection) + +-- | +-- Executes a bunch of commands on the provided connection. +run :: Session a -> Connection.Connection -> IO (Either SessionError a) +run (Session impl) connection = + mask $ \restore -> onException (restore main) handler + where + main = + runExceptT $ runReaderT impl connection + handler = + case connection of + Connection.Connection _ pqConnVar _ registry -> + withMVar pqConnVar \pqConn -> + Pq.transactionStatus pqConn >>= \case + Pq.TransIdle -> pure () + _ -> do + PreparedStatementRegistry.reset registry + Pq.reset pqConn + +-- | +-- Possibly a multi-statement query, +-- which however cannot be parameterized or prepared, +-- nor can any results of it be collected. +sql :: ByteString -> Session () +sql sql = + Session + $ ReaderT + $ \(Connection.Connection _ pqConnectionRef integerDatetimes _) -> + ExceptT + $ fmap (first (QueryError sql [])) + $ withMVar pqConnectionRef + $ \pqConnection -> do + r1 <- IO.sendNonparametricStatement pqConnection sql + r2 <- IO.getResults pqConnection integerDatetimes decoder + return $ r1 *> r2 + where + decoder = + Decoders.Results.single Decoders.Result.noResult + +-- | +-- Execute a statement by providing parameters to it. +statement :: params -> Statement.Statement params result -> Session result +statement input (Statement.Statement template (Encoders.Params paramsEncoder) (Decoders.Result decoder) preparable) = + Session + $ ReaderT + $ \(Connection.Connection usePreparedStatements pqConnectionRef integerDatetimes registry) -> + ExceptT + $ fmap (first (QueryError template (Encoders.Params.renderReadable paramsEncoder input))) + $ withMVar pqConnectionRef + $ \pqConnection -> do + r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder (usePreparedStatements && preparable) input + r2 <- IO.getResults pqConnection integerDatetimes decoder + return $ r1 *> r2 + +-- | +-- Execute a pipeline. +pipeline :: Pipeline.Pipeline result -> Session result +pipeline pipeline = + Session $ ReaderT \(Connection.Connection usePreparedStatements pqConnectionRef integerDatetimes registry) -> + ExceptT $ withMVar pqConnectionRef \pqConnection -> + Pipeline.run pipeline usePreparedStatements pqConnection registry integerDatetimes diff --git a/src/hasql/Hasql/Statement.hs b/src/hasql/Hasql/Statement.hs new file mode 100644 index 0000000000..4070c4c8a4 --- /dev/null +++ b/src/hasql/Hasql/Statement.hs @@ -0,0 +1,126 @@ +module Hasql.Statement + ( Statement (..), + refineResult, + + -- * Recipes + + -- ** Insert many + -- $insertMany + + -- ** IN and NOT IN + -- $inAndNotIn + ) +where + +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Decoders.All as Decoders +import qualified Hasql.Encoders as Encoders +import Hasql.Prelude + +-- | +-- Specification of a strictly single-statement query, which can be parameterized and prepared. +-- It encapsulates the mapping of parameters and results in association with an SQL template. +-- +-- Following is an example of a declaration of a prepared statement with its associated codecs. +-- +-- @ +-- selectSum :: 'Statement' (Int64, Int64) Int64 +-- selectSum = +-- 'Statement' sql encoder decoder True +-- where +-- sql = +-- \"select ($1 + $2)\" +-- encoder = +-- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) '<>' +-- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) +-- decoder = +-- Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8')) +-- @ +-- +-- The statement above accepts a product of two parameters of type 'Int64' +-- and produces a single result of type 'Int64'. +data Statement params result + = Statement + -- | SQL template. + -- + -- Must be formatted according to the Postgres standard, + -- with any non-ASCII characters of the template encoded using UTF-8. + -- The parameters must be referred to using the positional notation, as in the following: + -- @$1@, @$2@, @$3@ and etc. + -- These references must be used in accordance with the order in which + -- the value encoders are specified in the parameters encoder. + ByteString + -- | Parameters encoder. + (Encoders.Params params) + -- | Decoder of result. + (Decoders.Result result) + -- | Flag, determining whether it can be prepared. + -- + -- Set it to 'True' if your application has a limited amount of queries and doesn't generate the SQL dynamically. + -- This will boost the performance by allowing Postgres to avoid reconstructing the execution plan each time the query gets executed. + Bool + +instance Functor (Statement params) where + {-# INLINE fmap #-} + fmap = rmap + +instance Filterable (Statement params) where + {-# INLINE mapMaybe #-} + mapMaybe filtrator (Statement template encoder decoder preparable) = + Statement template encoder (mapMaybe filtrator decoder) preparable + +instance Profunctor Statement where + {-# INLINE dimap #-} + dimap f1 f2 (Statement template encoder decoder preparable) = + Statement template (contramap f1 encoder) (fmap f2 decoder) preparable + +-- | +-- Refine the result of a statement, +-- causing the running session to fail with the `UnexpectedResult` error in case of a refinement failure. +-- +-- This function is especially useful for refining the results of statements produced with +-- . +refineResult :: (a -> Either Text b) -> Statement params a -> Statement params b +refineResult refiner (Statement template encoder decoder preparable) = + Statement template encoder (Decoders.refineResult refiner decoder) preparable + +-- $insertMany +-- +-- Starting from PostgreSQL 9.4 there is an @unnest@ function which we can use in an analogous way +-- to haskell's `zip` to pass in multiple arrays of values +-- to be zipped into the rows to insert as in the following example: +-- +-- @ +-- insertMultipleLocations :: 'Statement' (Vector (UUID, Double, Double)) () +-- insertMultipleLocations = +-- 'Statement' sql encoder decoder True +-- where +-- sql = +-- "insert into location (id, x, y) select * from unnest ($1, $2, $3)" +-- encoder = +-- Data.Vector.'Data.Vector.unzip3' '>$<' +-- Contravariant.Extras.contrazip3 +-- (Encoders.'Encoders.param' $ Encoders.'Encoders.nonNullable' $ Encoders.'Encoders.foldableArray' $ Encoders.'Encoders.nonNullable' Encoders.'Encoders.uuid') +-- (Encoders.'Encoders.param' $ Encoders.'Encoders.nonNullable' $ Encoders.'Encoders.foldableArray' $ Encoders.'Encoders.nonNullable' Encoders.'Encoders.float8') +-- (Encoders.'Encoders.param' $ Encoders.'Encoders.nonNullable' $ Encoders.'Encoders.foldableArray' $ Encoders.'Encoders.nonNullable' Encoders.'Encoders.float8') +-- decoder = +-- Decoders.'Decoders.noResult' +-- @ +-- +-- While this approach is much more efficient than executing a single-row insert-statement multiple times from within 'Session', a comparable performance can also be achieved by executing a single-insert statement from within a 'Pipeline'. + +-- $inAndNotIn +-- +-- There is a common misconception that PostgreSQL supports array +-- as the parameter for the @IN@ operator. +-- However Postgres only supports a syntactical list of values with it, +-- i.e., you have to specify each option as an individual parameter. +-- E.g., @some_expression IN ($1, $2, $3)@. +-- +-- Fortunately, Postgres does provide the expected functionality for arrays with other operators: +-- +-- * Use @some_expression = ANY($1)@ instead of @some_expression IN ($1)@ +-- * Use @some_expression <> ALL($1)@ instead of @some_expression NOT IN ($1)@ +-- +-- For details refer to +-- . diff --git a/src/hasql/Hasql/Transaction.hs b/src/hasql/Hasql/Transaction.hs new file mode 100644 index 0000000000..9c0de9a6af --- /dev/null +++ b/src/hasql/Hasql/Transaction.hs @@ -0,0 +1,12 @@ +-- | +-- An API for declaration of transactions. +module Hasql.Transaction + ( -- * Transaction monad + Transaction, + condemn, + sql, + statement, + ) +where + +import Hasql.Transaction.Private.Transaction diff --git a/src/hasql/Hasql/Transaction/Config.hs b/src/hasql/Hasql/Transaction/Config.hs new file mode 100644 index 0000000000..fac010ed94 --- /dev/null +++ b/src/hasql/Hasql/Transaction/Config.hs @@ -0,0 +1,21 @@ +module Hasql.Transaction.Config where + +import Hasql.Transaction.Private.Prelude + +data Mode + = -- | + -- Read-only. No writes possible. + Read + | -- | + -- Write and commit. + Write + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | +-- For reference see +-- . +data IsolationLevel + = ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Ord, Enum, Bounded) diff --git a/src/hasql/Hasql/Transaction/Private/Prelude.hs b/src/hasql/Hasql/Transaction/Private/Prelude.hs new file mode 100644 index 0000000000..f3d9e06ea1 --- /dev/null +++ b/src/hasql/Hasql/Transaction/Private/Prelude.hs @@ -0,0 +1,144 @@ +module Hasql.Transaction.Private.Prelude + ( module Exports, + tryError, + ) +where + +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, + forM, forM_, + join, mapM, + mapM_, msum, + sequence, + sequence_) +import Control.Monad.Error.Class as Exports (MonadError (..)) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST 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.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, + (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports +import Data.Functor.Identity as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, + and, any, + concat, + concatMap, + elem, find, + foldl, foldl', + foldl1, foldr, + foldr1, + isSubsequenceOf, + mapAccumL, + mapAccumR, + maximum, + maximumBy, + minimum, + minimumBy, + notElem, or, + product, + sortOn, sum, + uncons) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (Alt, + First (..), + Last (..), + (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Semigroup as Exports +import Data.STRef as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding + (alignment, + sizeOf) +import GHC.Conc as Exports hiding + (threadWaitRead, + threadWaitReadSTM, + threadWaitWrite, + threadWaitWriteSTM, + withMVar) +import GHC.Exts as Exports (IsList (..), + groupWith, + inline, lazy, + sortWith) +import GHC.Generics as Exports (Generic, + Generic1) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (all, + and, any, + concat, + concatMap, + elem, fail, + foldl, foldl1, + foldr, foldr1, + id, mapM, + mapM_, + maximum, + minimum, + notElem, or, + product, + sequence, + sequence_, + sum, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, + printf) +import Text.Read as Exports (Read (..), + readEither, + readMaybe) +import Unsafe.Coerce as Exports + +tryError :: (MonadError e m) => m a -> m (Either e a) +tryError m = + catchError (fmap Right m) (return . Left) diff --git a/src/hasql/Hasql/Transaction/Private/SQL.hs b/src/hasql/Hasql/Transaction/Private/SQL.hs new file mode 100644 index 0000000000..0e042ca47e --- /dev/null +++ b/src/hasql/Hasql/Transaction/Private/SQL.hs @@ -0,0 +1,22 @@ +module Hasql.Transaction.Private.SQL where + +import qualified ByteString.TreeBuilder as D +import Hasql.Transaction.Config +import Hasql.Transaction.Private.Prelude + +beginTransaction :: IsolationLevel -> Mode -> ByteString +beginTransaction isolation mode = + D.toByteString builder + where + builder = + "BEGIN " <> isolationBuilder <> " " <> modeBuilder + where + isolationBuilder = + case isolation of + ReadCommitted -> "ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ" + Serializable -> "ISOLATION LEVEL SERIALIZABLE" + modeBuilder = + case mode of + Write -> "READ WRITE" + Read -> "READ ONLY" diff --git a/src/hasql/Hasql/Transaction/Private/Sessions.hs b/src/hasql/Hasql/Transaction/Private/Sessions.hs new file mode 100644 index 0000000000..d61376332f --- /dev/null +++ b/src/hasql/Hasql/Transaction/Private/Sessions.hs @@ -0,0 +1,50 @@ +module Hasql.Transaction.Private.Sessions where + +import Hasql.Session +import Hasql.Transaction.Config +import Hasql.Transaction.Private.Prelude +import qualified Hasql.Transaction.Private.Statements as Statements + +{- +We may want to +do one transaction retry in case of the 23505 error, and fail if an identical +error is seen. +-} +inRetryingTransaction :: IsolationLevel -> Mode -> Bool -> Session (a, Bool) -> Session a +inRetryingTransaction level mode retryOnError session = + fix $ \retry -> do + attemptRes <- tryTransaction level mode retryOnError session + maybe retry return attemptRes + +tryTransaction :: IsolationLevel -> Mode -> Bool -> Session (a, Bool) -> Session (Maybe a) +tryTransaction level mode retryOnError body = do + statement () (Statements.beginTransaction level mode) + + bodyRes <- catchError (fmap Just body) $ \error -> do + statement () Statements.abortTransaction + handleTransactionError error retryOnError $ return Nothing + + case bodyRes of + Just (res, commit) -> catchError (commitOrAbort commit $> Just res) $ \error -> do + handleTransactionError error retryOnError $ return Nothing + Nothing -> return Nothing + +commitOrAbort :: Bool -> Session () +commitOrAbort commit = + if commit + then statement () Statements.commitTransaction + else statement () Statements.abortTransaction + +handleTransactionError :: SessionError -> Bool -> Session a -> Session a +handleTransactionError error retryOnError onTransactionError = case error of + QueryError _ _ clientError -> onCommandError clientError + PipelineError clientError -> onCommandError clientError + where + retryOrThrow = if retryOnError then onTransactionError else throwError error + onCommandError = \case + ResultError (ServerError code _ _ _ _) -> + case code of + "40001" -> retryOrThrow + "40P01" -> retryOrThrow + _ -> throwError error + _ -> throwError error diff --git a/src/hasql/Hasql/Transaction/Private/Statements.hs b/src/hasql/Hasql/Transaction/Private/Statements.hs new file mode 100644 index 0000000000..11cbb2c41a --- /dev/null +++ b/src/hasql/Hasql/Transaction/Private/Statements.hs @@ -0,0 +1,20 @@ +module Hasql.Transaction.Private.Statements where + +import qualified Hasql.Decoders as C +import qualified Hasql.Encoders as B +import qualified Hasql.Statement as A +import Hasql.Transaction.Config +import Hasql.Transaction.Private.Prelude +import qualified Hasql.Transaction.Private.SQL as D + +beginTransaction :: IsolationLevel -> Mode -> A.Statement () () +beginTransaction isolation mode = + A.Statement (D.beginTransaction isolation mode) B.noParams C.noResult True + +commitTransaction :: A.Statement () () +commitTransaction = + A.Statement "COMMIT" B.noParams C.noResult True + +abortTransaction :: A.Statement () () +abortTransaction = + A.Statement "ABORT" B.noParams C.noResult True diff --git a/src/hasql/Hasql/Transaction/Private/Transaction.hs b/src/hasql/Hasql/Transaction/Private/Transaction.hs new file mode 100644 index 0000000000..a58884e678 --- /dev/null +++ b/src/hasql/Hasql/Transaction/Private/Transaction.hs @@ -0,0 +1,53 @@ +module Hasql.Transaction.Private.Transaction where + +import qualified Hasql.Session as B +import qualified Hasql.Statement as A +import Hasql.Transaction.Config +import Hasql.Transaction.Private.Prelude +import qualified Hasql.Transaction.Private.Sessions as D + +-- | +-- A composable abstraction over the retryable transactions. +-- +-- Executes multiple queries under the specified mode and isolation level, +-- while automatically retrying the transaction in case of conflicts. +-- Thus this abstraction closely reproduces the behaviour of 'STM'. +newtype Transaction a + = Transaction (StateT Bool B.Session a) + deriving (Functor, Applicative, Monad) + +instance (Semigroup a) => Semigroup (Transaction a) where + (<>) = liftA2 (<>) + +instance (Monoid a) => Monoid (Transaction a) where + mempty = pure mempty + +-- | +-- Execute the transaction using the provided isolation level and mode. +{-# INLINE run #-} +run :: Transaction a -> IsolationLevel -> Mode -> Bool -> B.Session a +run (Transaction session) isolation mode retryOnError = + D.inRetryingTransaction isolation mode retryOnError (runStateT session True) + +-- | +-- Possibly a multi-statement query, +-- which however cannot be parameterized or prepared, +-- nor can any results of it be collected. +{-# INLINE sql #-} +sql :: ByteString -> Transaction () +sql = + Transaction . lift . B.sql + +-- | +-- Parameters and a specification of the parametric query to apply them to. +{-# INLINE statement #-} +statement :: a -> A.Statement a b -> Transaction b +statement params statement = + Transaction . lift $ B.statement params statement + +-- | +-- Cause transaction to eventually roll back. +{-# INLINE condemn #-} +condemn :: Transaction () +condemn = + Transaction $ put False diff --git a/src/hasql/Hasql/Transaction/Sessions.hs b/src/hasql/Hasql/Transaction/Sessions.hs new file mode 100644 index 0000000000..f02dfa74b5 --- /dev/null +++ b/src/hasql/Hasql/Transaction/Sessions.hs @@ -0,0 +1,28 @@ +module Hasql.Transaction.Sessions + ( transaction, + transactionNoRetry, + + -- * Transaction settings + C.Mode (..), + C.IsolationLevel (..), + ) +where + +import qualified Hasql.Session as B +import qualified Hasql.Transaction.Config as C +import Hasql.Transaction.Private.Prelude +import qualified Hasql.Transaction.Private.Transaction as A + +-- | +-- Execute the transaction using the provided isolation level and mode. +{-# INLINE transaction #-} +transaction :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a +transaction isolation mode transaction = + A.run transaction isolation mode True + +-- | +-- Execute the transaction but do not retry it on errors. +{-# INLINE transactionNoRetry #-} +transactionNoRetry :: C.IsolationLevel -> C.Mode -> A.Transaction a -> B.Session a +transactionNoRetry isolation mode transaction = + A.run transaction isolation mode False diff --git a/vendor/hasql-dynamic-statements/hasql-dynamic-statements.cabal b/vendor/hasql-dynamic-statements/hasql-dynamic-statements.cabal new file mode 100644 index 0000000000..033ad4b3bd --- /dev/null +++ b/vendor/hasql-dynamic-statements/hasql-dynamic-statements.cabal @@ -0,0 +1,57 @@ +common base + default-language: Haskell2010 + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +test-suite test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + hasql, + hasql-dynamic-statements, + rerebase <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, diff --git a/vendor/hasql-dynamic-statements/test/Main.hs b/vendor/hasql-dynamic-statements/test/Main.hs new file mode 100644 index 0000000000..7d0b2bb199 --- /dev/null +++ b/vendor/hasql-dynamic-statements/test/Main.hs @@ -0,0 +1,75 @@ +module Main where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as ByteStringChar8 +import qualified Hasql.Connection as Connection +import qualified Hasql.Decoders as Decoders +import qualified Hasql.DynamicStatements.Session as Session +import qualified Hasql.DynamicStatements.Snippet as Snippet +import qualified Hasql.DynamicStatements.Statement as Statement +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import Prelude hiding (assert) +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = + defaultMain tree + +tree :: TestTree +tree = + testGroup + "All tests" + [ testCase "Select substring" + $ let sample string from to = + let snippet = + "select substring(" + <> Snippet.param @Text string + <> foldMap (mappend " from " . Snippet.param @Int32) from + <> foldMap (mappend " for " . Snippet.param @Int32) to + <> ")" + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.text)) + in runSession (Session.dynamicallyParameterizedStatement snippet decoder True) + in do + assertEqual "" (Right (Right "bc")) =<< sample "abcd" (Just 2) (Just 2) + assertEqual "" (Right (Right "bcd")) =<< sample "abcd" (Just 2) (Just 3) + assertEqual "" (Right (Right "abc")) =<< sample "abcd" Nothing (Just 3) + assertEqual "" (Right (Right "bcd")) =<< sample "abcd" (Just 2) Nothing, + testGroup + "Regression" + [ testCase "Missing $ for 1000th parameter string #2" + $ let snippet = + "SELECT 1 " <> foldMap @[] ("," <>) (replicate 1001 $ Snippet.param (10 :: Int64)) + statement = + Statement.dynamicallyParameterized snippet Decoders.noResult True + sql = + case statement of + Statement.Statement x _ _ _ -> x + in do + assertBool (ByteStringChar8.unpack sql) (ByteString.isInfixOf "$1000" sql) + ] + ] + +runSession :: Session.Session a -> IO (Either Connection.ConnectionError (Either Session.SessionError a)) +runSession = withConnection . Session.run + +withConnection :: (Connection.Connection -> IO a) -> IO (Either Connection.ConnectionError a) +withConnection handler = + runExceptT $ acquire >>= \connection -> use connection <* release connection + where + acquire = + ExceptT $ Connection.acquire settings + where + settings = + Connection.settings host port user password database + where + host = "localhost" + port = 5432 + user = "postgres" + password = "postgres" + database = "postgres" + use connection = + lift $ handler connection + release connection = + lift $ Connection.release connection diff --git a/vendor/hasql-notifications/hasql-notifications.cabal b/vendor/hasql-notifications/hasql-notifications.cabal new file mode 100644 index 0000000000..e53dd73649 --- /dev/null +++ b/vendor/hasql-notifications/hasql-notifications.cabal @@ -0,0 +1,28 @@ +library + hs-source-dirs: src + exposed-modules: Hasql.Notifications + build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10.8.2 && < 0.13 + , text >= 2 && < 2.2 + , hasql-pool >= 1.3 && < 1.4 + , postgresql-libpq >= 0.9 && < 1.0 + , hasql >= 1.9 && < 1.10 + + default-language: Haskell2010 + ghc-options: -Wall + default-extensions: OverloadedStrings + +test-suite hasql-notifications-test + type: exitcode-stdio-1.0 + other-modules: Hasql.NotificationsSpec + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hasql + , hasql-notifications + , hspec + , bytestring + , QuickCheck + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings diff --git a/vendor/hasql-notifications/test/Hasql/NotificationsSpec.hs b/vendor/hasql-notifications/test/Hasql/NotificationsSpec.hs new file mode 100644 index 0000000000..f1dfe27c14 --- /dev/null +++ b/vendor/hasql-notifications/test/Hasql/NotificationsSpec.hs @@ -0,0 +1,44 @@ +module Hasql.NotificationsSpec (main, spec) where + +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.MVar +import Control.Monad (void) +import Data.ByteString +import Hasql.Connection +import Hasql.Connection.Setting +import Hasql.Connection.Setting.Connection +import Hasql.Notifications +import System.Exit (die) +import Test.Hspec +import Test.QuickCheck + +-- `main` is here so that this module can be run from GHCi on its own. It is +-- not needed for automatic spec discovery. +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "send and receive notification" $ + describe "when I send a notification to channel my handler is listening to" $ + it "should call our notification handler" $ do + dbOrError <- acquire [ connection $ string "postgres://postgres:roottoor@localhost/hasql_notifications_test"] + case dbOrError of + Right db -> do + let channelToListen = toPgIdentifier "test-channel" + mailbox <- newEmptyMVar :: IO (MVar ByteString) + listen db channelToListen + threadId <- forkIO $ waitForNotifications (\channel payload -> putMVar mailbox $ "Just got notification on channel " <> channel <> ": " <> payload) db + notify db (toPgIdentifier "test-channel") "Payload" + takeMVar mailbox `shouldReturn` "Just got notification on channel test-channel: Payload" + _ -> die "Could not open database connection" + + describe "FatalError show instance" $ + it "extracts message" $ + ( show $ + FatalError {fatalErrorMessage = "some message"} + ) + `shouldBe` "some message" + describe "toPgIdenfier" $ + it "enclose text in quotes doubling existing ones" $ + fromPgIdentifier (toPgIdentifier "some \"identifier\"") `shouldBe` "\"some \"\"identifier\"\"\"" diff --git a/vendor/hasql-notifications/test/Spec.hs b/vendor/hasql-notifications/test/Spec.hs new file mode 100644 index 0000000000..a824f8c30c --- /dev/null +++ b/vendor/hasql-notifications/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vendor/hasql-pool/hasql-pool.cabal b/vendor/hasql-pool/hasql-pool.cabal new file mode 100644 index 0000000000..18e99d44b4 --- /dev/null +++ b/vendor/hasql-pool/hasql-pool.cabal @@ -0,0 +1,57 @@ +common base-settings + default-language: Haskell2010 + default-extensions: + ApplicativeDo + Arrows + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + NumericUnderscores + OverloadedStrings + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + +test-suite test + import: base-settings + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Main.hs + ghc-options: -threaded + build-depends: + async >=2.2 && <3, + hasql, + hasql-pool, + hspec >=2.6 && <3, + random >=1.2 && <2, + rerebase >=1.15 && <2, diff --git a/vendor/hasql-pool/src/test/Main.hs b/vendor/hasql-pool/src/test/Main.hs new file mode 100644 index 0000000000..e1d934079e --- /dev/null +++ b/vendor/hasql-pool/src/test/Main.hs @@ -0,0 +1,232 @@ +module Main where + +import Control.Concurrent.Async (race) +import qualified Data.Text as Text +import qualified Hasql.Connection as Connection +import qualified Hasql.Connection.Setting as Connection.Setting +import qualified Hasql.Connection.Setting.Connection as Connection.Setting.Connection +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import Hasql.Pool +import qualified Hasql.Pool.Config as Config +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import Prelude +import qualified System.Environment +import qualified System.Random.Stateful as Random +import Test.Hspec + +main :: IO () +main = do + connectionString <- getConnectionString + let withPool poolSize acqTimeout maxLifetime maxIdletime connectionString = + bracket + ( acquire + ( Config.settings + [ Config.size poolSize, + Config.acquisitionTimeout acqTimeout, + Config.agingTimeout maxLifetime, + Config.idlenessTimeout maxIdletime, + Config.staticConnectionSettings + [ Connection.Setting.connection + (Connection.Setting.Connection.string connectionString) + ] + ] + ) + ) + release + withDefaultPool = + withPool 3 10 1_800 1_800 connectionString + + hspec . describe "" $ do + it "Releases a spot in the pool when there is a query error" $ withDefaultPool $ \pool -> do + use pool badQuerySession `shouldNotReturn` Right () + use pool selectOneSession `shouldReturn` Right 1 + it "Simulation of connection error works" $ withDefaultPool $ \pool -> do + res <- use pool $ closeConnSession >> selectOneSession + shouldSatisfy res $ \case + Left (SessionUsageError (Session.QueryError _ _ (Session.ClientError _))) -> True + _ -> False + it "Connection errors cause eviction of connection" $ withDefaultPool $ \pool -> do + _ <- use pool $ closeConnSession >> selectOneSession + _ <- use pool $ closeConnSession >> selectOneSession + _ <- use pool $ closeConnSession >> selectOneSession + res <- use pool selectOneSession + shouldSatisfy res isRight + it "Connection gets returned to the pool after normal use" $ withDefaultPool $ \pool -> do + _ <- use pool selectOneSession + _ <- use pool selectOneSession + _ <- use pool selectOneSession + _ <- use pool selectOneSession + res <- use pool selectOneSession + shouldSatisfy res isRight + it "Connection gets returned to the pool after non-connection error" $ withDefaultPool $ \pool -> do + _ <- use pool badQuerySession + _ <- use pool badQuerySession + _ <- use pool badQuerySession + _ <- use pool badQuerySession + res <- use pool selectOneSession + shouldSatisfy res isRight + it "The pool remains usable after release" $ withDefaultPool $ \pool -> do + _ <- use pool selectOneSession + release pool + res <- use pool selectOneSession + shouldSatisfy res isRight + it "Getting and setting session variables works" $ withDefaultPool $ \pool -> do + res <- use pool $ getSettingSession "testing.foo" + res `shouldBe` Right Nothing + res <- use pool $ do + setSettingSession "testing.foo" "hello world" + getSettingSession "testing.foo" + res `shouldBe` Right (Just "hello world") + it "Session variables stay set when a connection gets reused" $ withPool 1 10 1_800 1_800 connectionString $ \pool -> do + res <- use pool $ setSettingSession "testing.foo" "hello world" + res `shouldBe` Right () + res2 <- use pool $ getSettingSession "testing.foo" + res2 `shouldBe` Right (Just "hello world") + it "Releasing the pool resets session variables" $ withPool 1 10 1_800 1_800 connectionString $ \pool -> do + res <- use pool $ setSettingSession "testing.foo" "hello world" + res `shouldBe` Right () + release pool + res <- use pool $ getSettingSession "testing.foo" + res `shouldBe` Right Nothing + it "Times out connection acquisition" + $ + -- 1ms timeout + -- 1ms timeout + -- 1ms timeout + withPool 1 0.001 1_800 1_800 connectionString + $ \pool -> do + sleeping <- newEmptyMVar + t0 <- getCurrentTime + res <- + race + ( use pool + $ liftIO + $ do + putMVar sleeping () + threadDelay 1_000_000 -- 1s + ) + ( do + takeMVar sleeping + use pool selectOneSession + ) + t1 <- getCurrentTime + res `shouldBe` Right (Left AcquisitionTimeoutUsageError) + diffUTCTime t1 t0 `shouldSatisfy` (< 0.5) -- 0.5s + it "Passively times out old connections (maxLifetime)" + $ + -- 0.5s connection lifetime + -- 0.5s connection lifetime + -- 0.5s connection lifetime + withPool 1 10 0.5 1_800 connectionString + $ \pool -> do + res <- use pool $ setSettingSession "testing.foo" "hello world" + res `shouldBe` Right () + res2 <- use pool $ getSettingSession "testing.foo" + res2 `shouldBe` Right (Just "hello world") + threadDelay 1_000_000 -- 1s + res3 <- use pool $ getSettingSession "testing.foo" + res3 `shouldBe` Right Nothing + it "Counts active connections" $ do + (taggedConnectionSettings, appName) <- tagConnection connectionString + withPool 3 10 1_800 1_800 taggedConnectionSettings $ \pool -> do + res <- use pool $ countConnectionsSession appName + res `shouldBe` Right 1 + + it "Actively times out old connections (maxLifetime)" $ do + withDefaultPool $ \countPool -> do + (taggedConnectionSettings, appName) <- tagConnection connectionString + withPool 3 10 0.5 1_800 taggedConnectionSettings $ \limitedPool -> do + res <- use limitedPool selectOneSession + res `shouldBe` Right 1 + res2 <- use countPool $ countConnectionsSession appName + res2 `shouldBe` Right 1 + threadDelay 1_000_000 -- 1s + res3 <- use countPool $ countConnectionsSession appName + res3 `shouldBe` Right 0 + it "Times out old connections (maxIdletime)" $ do + -- 0.5s connection idle time + withPool 1 10 1_800 0.5 connectionString $ \pool -> do + res <- use pool $ setSettingSession "testing.foo" "hello world" + res `shouldBe` Right () + res2 <- use pool $ getSettingSession "testing.foo" + res2 `shouldBe` Right (Just "hello world") + -- busy sleep, to keep connection alive + forM_ [1 :: Int .. 10] $ \_ -> do + r <- use pool selectOneSession + r `shouldBe` Right 1 + threadDelay 100_000 -- 0.1s + res3 <- use pool $ getSettingSession "testing.foo" + res3 `shouldBe` Right (Just "hello world") + -- idle sleep, connection times out + threadDelay 1_000_000 -- 1s + res4 <- use pool $ getSettingSession "testing.foo" + res4 `shouldBe` Right Nothing + +getConnectionString :: IO Text +getConnectionString = + Text.unwords + . catMaybes + <$> sequence + [ setting "host" $ defaultEnv "POSTGRES_HOST" "localhost", + setting "port" $ defaultEnv "POSTGRES_PORT" "5432", + setting "user" $ defaultEnv "POSTGRES_USER" "postgres", + setting "password" $ defaultEnv "POSTGRES_PASSWORD" "postgres", + setting "dbname" $ defaultEnv "POSTGRES_DBNAME" "postgres" + ] + where + maybeEnv env = fmap Text.pack <$> System.Environment.lookupEnv env + defaultEnv env val = Just . fromMaybe val <$> maybeEnv env + setting label getEnv = do + val <- getEnv + return $ (\v -> label <> "=" <> v) <$> val + +tagConnection :: Text -> IO (Text, Text) +tagConnection connectionString = do + tag <- Random.uniformWord32 Random.globalStdGen + let appName = "hasql-pool-test-" <> show tag + return (connectionString <> " application_name=" <> Text.pack appName, Text.pack appName) + +selectOneSession :: Session.Session Int64 +selectOneSession = + Session.statement () statement + where + statement = Statement.Statement "SELECT 1" Encoders.noParams decoder True + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)) + +badQuerySession :: Session.Session () +badQuerySession = + Session.statement () statement + where + statement = Statement.Statement "zzz" Encoders.noParams Decoders.noResult True + +closeConnSession :: Session.Session () +closeConnSession = do + conn <- ask + liftIO $ Connection.release conn + +setSettingSession :: Text -> Text -> Session.Session () +setSettingSession name value = do + Session.statement (name, value) statement + where + statement = Statement.Statement "SELECT set_config($1, $2, false)" encoder Decoders.noResult True + encoder = + contramap fst (Encoders.param (Encoders.nonNullable Encoders.text)) + <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text)) + +getSettingSession :: Text -> Session.Session (Maybe Text) +getSettingSession name = do + Session.statement name statement + where + statement = Statement.Statement "SELECT current_setting($1, true)" encoder decoder True + encoder = Encoders.param (Encoders.nonNullable Encoders.text) + decoder = Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text)) + +countConnectionsSession :: Text -> Session.Session Int64 +countConnectionsSession appName = do + Session.statement appName statement + where + statement = Statement.Statement "SELECT count(*) FROM pg_stat_activity WHERE application_name = $1" encoder decoder True + encoder = Encoders.param (Encoders.nonNullable Encoders.text) + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)) diff --git a/vendor/hasql-transaction/conflicts-test/Main.hs b/vendor/hasql-transaction/conflicts-test/Main.hs new file mode 100644 index 0000000000..1c6a4457bf --- /dev/null +++ b/vendor/hasql-transaction/conflicts-test/Main.hs @@ -0,0 +1,127 @@ +module Main where + +import qualified Control.Concurrent.Async as F +import qualified Hasql.Connection as A +import qualified Hasql.Connection.Setting as H +import qualified Hasql.Connection.Setting.Connection as I +import qualified Hasql.Connection.Setting.Connection.Param as J +import qualified Hasql.Session as B +import qualified Hasql.Transaction as C +import qualified Hasql.Transaction.Sessions as G +import qualified Main.Statements as D +import qualified Main.Transactions as E +import Prelude + +main :: IO () +main = + bracket acquire release use + where + acquire = + (,) <$> acquire <*> acquire + where + acquire = + either (fail . show) return =<< A.acquire connectionSettings + where + connectionSettings = + [ H.connection + ( I.params + [ J.host "localhost", + J.port 5432, + J.user "postgres", + J.password "postgres", + J.dbname "postgres" + ] + ) + ] + release (connection1, connection2) = + do + transaction connection1 E.dropSchema + A.release connection1 + A.release connection2 + use (connection1, connection2) = + do + try (transaction connection1 E.dropSchema) :: IO (Either SomeException ()) + transaction connection1 E.createSchema + success <- fmap and (traverse runTest tests) + if success + then exitSuccess + else exitFailure + where + runTest test = + test connection1 connection2 + tests = + [readAndWriteTransactionsTest, transactionsTest, transactionsNoRetryTest, transactionAndQueryTest] + +session :: A.Connection -> B.Session a -> IO a +session connection session = + B.run session connection + >>= either (fail . show) return + +transaction :: A.Connection -> C.Transaction a -> IO a +transaction connection transaction = + session connection (G.transaction G.RepeatableRead G.Write transaction) + +transactionNoRetry :: A.Connection -> C.Transaction a -> IO a +transactionNoRetry connection transaction = + session connection (G.transactionNoRetry G.RepeatableRead G.Write transaction) + +type Test = + A.Connection -> A.Connection -> IO Bool + +transactionsTest :: Test +transactionsTest connection1 connection2 = + do + id1 <- session connection1 (B.statement 0 D.createAccount) + id2 <- session connection1 (B.statement 0 D.createAccount) + async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transaction connection2 (E.transfer id1 id2 1))) + F.wait async1 + F.wait async2 + balance1 <- session connection1 (B.statement id1 D.getBalance) + balance2 <- session connection1 (B.statement id2 D.getBalance) + traceShowM balance1 + traceShowM balance2 + return (balance1 == Just 2000 && balance2 == Just (-2000)) + +transactionsNoRetryTest :: Test +transactionsNoRetryTest connection1 connection2 = + do + id1 <- session connection1 (B.statement 0 D.createAccount) + id2 <- session connection1 (B.statement 0 D.createAccount) + async1 <- F.async (replicateM_ 1000 (transactionNoRetry connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transactionNoRetry connection2 (E.transfer id1 id2 1))) + result1 <- F.waitCatch async1 + result2 <- F.waitCatch async2 + let serialError = sequenceA [result1, result2] + traceShowM serialError + return $ either (("40001" `isInfixOf`) . show) (pure False) serialError + +readAndWriteTransactionsTest :: Test +readAndWriteTransactionsTest connection1 connection2 = + do + id1 <- session connection1 (B.statement 0 D.createAccount) + id2 <- session connection1 (B.statement 0 D.createAccount) + async1 <- F.async (replicateM_ 1000 (transaction connection1 (E.transfer id1 id2 1))) + async2 <- F.async (replicateM_ 1000 (transaction connection2 (C.statement id1 D.getBalance))) + F.wait async1 + F.wait async2 + balance1 <- session connection1 (B.statement id1 D.getBalance) + balance2 <- session connection1 (B.statement id2 D.getBalance) + traceShowM balance1 + traceShowM balance2 + return (balance1 == Just 1000 && balance2 == Just (-1000)) + +transactionAndQueryTest :: Test +transactionAndQueryTest connection1 connection2 = + do + id1 <- session connection1 (B.statement 0 D.createAccount) + id2 <- session connection1 (B.statement 0 D.createAccount) + async1 <- F.async (transaction connection1 (E.transferTimes 200 id1 id2 1)) + async2 <- F.async (session connection2 (replicateM_ 200 (B.statement (id1, 1) D.modifyBalance))) + F.wait async1 + F.wait async2 + balance1 <- session connection1 (B.statement id1 D.getBalance) + balance2 <- session connection1 (B.statement id2 D.getBalance) + traceShowM balance1 + traceShowM balance2 + return (balance1 == Just 400 && balance2 == Just (-200)) diff --git a/vendor/hasql-transaction/conflicts-test/Main/Statements.hs b/vendor/hasql-transaction/conflicts-test/Main/Statements.hs new file mode 100644 index 0000000000..bfdc3eb855 --- /dev/null +++ b/vendor/hasql-transaction/conflicts-test/Main/Statements.hs @@ -0,0 +1,45 @@ +module Main.Statements where + +import qualified Hasql.Decoders as D +import qualified Hasql.Encoders as E +import Hasql.Statement +import Prelude + +createAccountTable :: Statement () () +createAccountTable = + Statement sql E.noParams D.noResult False + where + sql = + "create table account (id serial not null, balance numeric not null, primary key (id))" + +dropAccountTable :: Statement () () +dropAccountTable = + Statement + "drop table account" + E.noParams + D.noResult + False + +createAccount :: Statement Scientific Int64 +createAccount = + Statement + "insert into account (balance) values ($1) returning id" + ((E.param . E.nonNullable) E.numeric) + (D.singleRow ((D.column . D.nonNullable) D.int8)) + True + +modifyBalance :: Statement (Int64, Scientific) Bool +modifyBalance = + Statement + "update account set balance = balance + $2 where id = $1" + ((fst >$< (E.param . E.nonNullable) E.int8) <> (snd >$< (E.param . E.nonNullable) E.numeric)) + (fmap (> 0) D.rowsAffected) + True + +getBalance :: Statement Int64 (Maybe Scientific) +getBalance = + Statement + "select balance from account where id = $1" + ((E.param . E.nonNullable) E.int8) + (D.rowMaybe ((D.column . D.nonNullable) D.numeric)) + True diff --git a/vendor/hasql-transaction/conflicts-test/Main/Transactions.hs b/vendor/hasql-transaction/conflicts-test/Main/Transactions.hs new file mode 100644 index 0000000000..3d60c5412a --- /dev/null +++ b/vendor/hasql-transaction/conflicts-test/Main/Transactions.hs @@ -0,0 +1,27 @@ +module Main.Transactions where + +import Hasql.Transaction +import qualified Main.Statements as A +import Prelude + +createSchema :: Transaction () +createSchema = + do + statement () A.createAccountTable + +dropSchema :: Transaction () +dropSchema = + do + statement () A.dropAccountTable + +transfer :: Int64 -> Int64 -> Scientific -> Transaction Bool +transfer id1 id2 amount = + do + success <- statement (id1, amount) A.modifyBalance + if success + then statement (id2, negate amount) A.modifyBalance + else return False + +transferTimes :: Int -> Int64 -> Int64 -> Scientific -> Transaction () +transferTimes times id1 id2 amount = + replicateM_ times (transfer id1 id2 amount) diff --git a/vendor/hasql-transaction/hasql-transaction.cabal b/vendor/hasql-transaction/hasql-transaction.cabal new file mode 100644 index 0000000000..999a5703dc --- /dev/null +++ b/vendor/hasql-transaction/hasql-transaction.cabal @@ -0,0 +1,66 @@ +common base + default-language: Haskell2010 + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeFamilies + TypeOperators + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +test-suite conflicts-test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: conflicts-test + main-is: Main.hs + other-modules: + Main.Statements + Main.Transactions + + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + + build-depends: + async >=2.1 && <3, + hasql >=1.9, + hasql-transaction, + rerebase >=1.11 && <2, diff --git a/vendor/hasql/benchmarks/Main.hs b/vendor/hasql/benchmarks/Main.hs new file mode 100644 index 0000000000..ffd7b09201 --- /dev/null +++ b/vendor/hasql/benchmarks/Main.hs @@ -0,0 +1,99 @@ +module Main where + +import Criterion +import Criterion.Main +import qualified Hasql.Connection as A +import qualified Hasql.Decoders as D +import qualified Hasql.Pipeline as E +import qualified Hasql.Session as B +import qualified Hasql.Statement as C +import Prelude + +main :: IO () +main = + do + Right connection <- acquireConnection + useConnection connection + where + acquireConnection = + A.acquire [] + useConnection connection = + defaultMain + [ sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector, + sessionBench "largeResultInList" sessionWithSingleLargeResultInList, + sessionBench "manyLargeResults" sessionWithManyLargeResults, + sessionBench "manyLargeResultsViaPipeline" sessionWithManyLargeResultsViaPipeline, + sessionBench "manySmallResults" sessionWithManySmallResults, + sessionBench "manySmallResultsViaPipeline" sessionWithManySmallResultsViaPipeline + ] + where + sessionBench :: (NFData a) => String -> B.Session a -> Benchmark + sessionBench name session = + bench name (nfIO (B.run session connection >>= either (fail . show) pure)) + +-- * Sessions + +sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64)) +sessionWithSingleLargeResultInVector = + B.statement () statementWithManyRowsInVector + +sessionWithSingleLargeResultInList :: B.Session [(Int64, Int64)] +sessionWithSingleLargeResultInList = + B.statement () statementWithManyRowsInList + +sessionWithManyLargeResults :: B.Session [Vector (Int64, Int64)] +sessionWithManyLargeResults = + replicateM 100 (B.statement () statementWithManyRowsInVector) + +sessionWithManySmallResults :: B.Session [(Int64, Int64)] +sessionWithManySmallResults = + replicateM 100 (B.statement () statementWithSingleRow) + +sessionWithManyLargeResultsViaPipeline :: B.Session [Vector (Int64, Int64)] +sessionWithManyLargeResultsViaPipeline = + B.pipeline (replicateM 100 (E.statement () statementWithManyRowsInVector)) + +sessionWithManySmallResultsViaPipeline :: B.Session [(Int64, Int64)] +sessionWithManySmallResultsViaPipeline = + B.pipeline (replicateM 100 (E.statement () statementWithSingleRow)) + +-- * Statements + +statementWithSingleRow :: C.Statement () (Int64, Int64) +statementWithSingleRow = + C.Statement template encoder decoder True + where + template = + "SELECT 1, 2" + encoder = + conquer + decoder = + D.singleRow row + where + row = + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 + where + tuple !a !b = + (a, b) + +statementWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Statement () result +statementWithManyRows decoder = + C.Statement template encoder (decoder rowDecoder) True + where + template = + "SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b" + encoder = + conquer + rowDecoder = + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 + where + tuple !a !b = + (a, b) + +statementWithManyRowsInVector :: C.Statement () (Vector (Int64, Int64)) +statementWithManyRowsInVector = + statementWithManyRows D.rowVector + +statementWithManyRowsInList :: C.Statement () [(Int64, Int64)] +statementWithManyRowsInList = + statementWithManyRows D.rowList diff --git a/vendor/hasql/hasql.cabal b/vendor/hasql/hasql.cabal new file mode 100644 index 0000000000..ab1c508d2e --- /dev/null +++ b/vendor/hasql/hasql.cabal @@ -0,0 +1,147 @@ +common base + default-language: Haskell2010 + default-extensions: + ApplicativeDo + Arrows + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + +common executable + import: base + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -rtsopts + -funbox-strict-fields + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +library testing-kit + import: base + visibility: private + hs-source-dirs: testing-kit + exposed-modules: + Hasql.TestingKit.Constants + Hasql.TestingKit.Preludes.Base + Hasql.TestingKit.Statements.BrokenSyntax + Hasql.TestingKit.Statements.GenerateSeries + Hasql.TestingKit.Statements.WrongDecoder + Hasql.TestingKit.TestingDsl + + build-depends: + base, + bytestring, + hasql, + transformers, + uuid, + +test-suite tasty + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: tasty + main-is: Main.hs + other-modules: + Main.Connection + Main.Prelude + Main.Statements + + build-depends: + contravariant-extras >=0.3.5.2 && <0.4, + hasql, + hasql:testing-kit, + quickcheck-instances >=0.3.11 && <0.4, + rerebase <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, + tasty-quickcheck >=0.9 && <0.12, + +test-suite threads-test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: threads-test + main-is: Main.hs + other-modules: Main.Statements + build-depends: + hasql, + rerebase, + +benchmark benchmarks + import: executable + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs + build-depends: + criterion >=1.6 && <2, + hasql, + rerebase <2, + +test-suite profiling + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: profiling + main-is: Main.hs + ghc-options: + -O2 + -threaded + -rtsopts + + build-depends: + hasql, + rerebase >=1 && <2, + +test-suite hspec + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: hspec + main-is: Main.hs + other-modules: + Hasql.ConnectionSpec + Hasql.PipelineSpec + + build-tool-depends: hspec-discover:hspec-discover + build-depends: + hasql, + hasql:testing-kit, + hspec, + rerebase >=1 && <2, + testcontainers-postgresql >=0.0.1 && <0.1, diff --git a/vendor/hasql/hspec/Hasql/ConnectionSpec.hs b/vendor/hasql/hspec/Hasql/ConnectionSpec.hs new file mode 100644 index 0000000000..3bf75e4555 --- /dev/null +++ b/vendor/hasql/hspec/Hasql/ConnectionSpec.hs @@ -0,0 +1,48 @@ +module Hasql.ConnectionSpec (spec) where + +import qualified Hasql.Connection +import qualified Hasql.Connection.Setting +import qualified Hasql.Connection.Setting.Connection +import qualified Hasql.Connection.Setting.Connection.Param +import Prelude +import Test.Hspec +import qualified TestcontainersPostgresql + +spec :: Spec +spec = do + describe "acquire" do + let itConnects :: Text -> Text -> Spec + itConnects username password = + describe ("username: " <> toList username) do + describe ("password: " <> toList password) do + it "connects" do + TestcontainersPostgresql.run + ( TestcontainersPostgresql.Config + { forwardLogs = False, + distro = TestcontainersPostgresql.Distro17, + auth = TestcontainersPostgresql.CredentialsAuth username password + } + ) + ( \(host, port) -> do + result <- + Hasql.Connection.acquire + [ Hasql.Connection.Setting.connection + ( Hasql.Connection.Setting.Connection.params + [ Hasql.Connection.Setting.Connection.Param.host host, + Hasql.Connection.Setting.Connection.Param.port (fromIntegral port), + Hasql.Connection.Setting.Connection.Param.user username, + Hasql.Connection.Setting.Connection.Param.password password + ] + ) + ] + case result of + Left err -> expectationFailure ("Connection failed: " <> show err <> ". Host: " <> show host <> ", port: " <> show port) + Right connection -> do + Hasql.Connection.release connection + pure () + ) + in do + itConnects "user" "new password" + itConnects "user" "new\\password" + itConnects "user" "new'password" + itConnects "new user" "password" diff --git a/vendor/hasql/hspec/Hasql/PipelineSpec.hs b/vendor/hasql/hspec/Hasql/PipelineSpec.hs new file mode 100644 index 0000000000..c8d3c145e5 --- /dev/null +++ b/vendor/hasql/hspec/Hasql/PipelineSpec.hs @@ -0,0 +1,93 @@ +module Hasql.PipelineSpec (spec) where + +import qualified Hasql.TestingKit.Statements.BrokenSyntax as BrokenSyntax +import qualified Hasql.TestingKit.Statements.GenerateSeries as GenerateSeries +import qualified Hasql.TestingKit.Statements.WrongDecoder as WrongDecoder +import qualified Hasql.TestingKit.TestingDsl as Dsl +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + describe "Single-statement" do + describe "Unprepared" do + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [0 .. 2]) + + describe "Prepared" do + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [0 .. 2]) + + describe "Multi-statement" do + describe "On unprepared statements" do + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ replicateM 2 + $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [[0 .. 2], [0 .. 2]]) + + describe "On prepared statements" do + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ replicateM 2 + $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [[0 .. 2], [0 .. 2]]) + + describe "When a part in the middle fails" do + describe "With query error" do + it "Captures the error" do + result <- + Dsl.runPipelineOnLocalDb + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> BrokenSyntax.pipeline True BrokenSyntax.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + case result of + Left (Dsl.SessionError (Dsl.QueryError {})) -> pure () + _ -> expectationFailure $ "Unexpected result: " <> show result + + it "Leaves the connection usable" do + result <- + Dsl.runSessionOnLocalDb do + _ <- + tryError + $ Dsl.runPipelineInSession + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> BrokenSyntax.pipeline True BrokenSyntax.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + GenerateSeries.session True GenerateSeries.Params {start = 0, end = 0} + shouldBe result (Right [0]) + + describe "With decoding error" do + it "Captures the error" do + result <- + Dsl.runPipelineOnLocalDb + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> WrongDecoder.pipeline True WrongDecoder.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + case result of + Left (Dsl.SessionError (Dsl.QueryError {})) -> pure () + _ -> expectationFailure $ "Unexpected result: " <> show result + + it "Leaves the connection usable" do + result <- + Dsl.runSessionOnLocalDb do + _ <- + tryError + $ Dsl.runPipelineInSession + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> WrongDecoder.pipeline True WrongDecoder.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + GenerateSeries.session True GenerateSeries.Params {start = 0, end = 0} + shouldBe result (Right [0]) diff --git a/vendor/hasql/hspec/Main.hs b/vendor/hasql/hspec/Main.hs new file mode 100644 index 0000000000..a824f8c30c --- /dev/null +++ b/vendor/hasql/hspec/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vendor/hasql/profiling/Main.hs b/vendor/hasql/profiling/Main.hs new file mode 100644 index 0000000000..8832ae4957 --- /dev/null +++ b/vendor/hasql/profiling/Main.hs @@ -0,0 +1,96 @@ +module Main where + +import qualified Data.Vector as F +import qualified Hasql.Connection as A +import qualified Hasql.Connection.Setting as E +import qualified Hasql.Connection.Setting.Connection as F +import qualified Hasql.Connection.Setting.Connection.Param as G +import qualified Hasql.Decoders as D +import qualified Hasql.Session as B +import qualified Hasql.Statement as C +import Prelude + +main :: IO () +main = + do + Right connection <- acquireConnection + traceEventIO "START Session" + Right _ <- B.run sessionWithManySmallResults connection + traceEventIO "STOP Session" + return () + where + acquireConnection = + A.acquire + [ E.connection + ( F.params + [ G.host "localhost", + G.port 5432, + G.user "postgres", + G.password "postgres", + G.dbname "postgres" + ] + ) + ] + +-- * Sessions + +sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session () +sessionWithManySmallParameters = + error "TODO: sessionWithManySmallParameters" + +sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64)) +sessionWithSingleLargeResultInVector = + B.statement () statementWithManyRowsInVector + +sessionWithSingleLargeResultInList :: B.Session [(Int64, Int64)] +sessionWithSingleLargeResultInList = + B.statement () statementWithManyRowsInList + +sessionWithManySmallResults :: B.Session (Vector (Int64, Int64)) +sessionWithManySmallResults = + F.replicateM 1000 (B.statement () statementWithSingleRow) + +-- * Statements + +statementWithManyParameters :: C.Statement (Vector (Int64, Int64)) () +statementWithManyParameters = + error "TODO: statementWithManyParameters" + +statementWithSingleRow :: C.Statement () (Int64, Int64) +statementWithSingleRow = + C.Statement template encoder decoder True + where + template = + "SELECT 1, 2" + encoder = + conquer + decoder = + D.singleRow row + where + row = + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 + where + tuple !a !b = + (a, b) + +statementWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Statement () result +statementWithManyRows decoder = + C.Statement template encoder (decoder rowDecoder) True + where + template = + "SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b" + encoder = + conquer + rowDecoder = + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 + where + tuple !a !b = + (a, b) + +statementWithManyRowsInVector :: C.Statement () (Vector (Int64, Int64)) +statementWithManyRowsInVector = + statementWithManyRows D.rowVector + +statementWithManyRowsInList :: C.Statement () [(Int64, Int64)] +statementWithManyRowsInList = + statementWithManyRows D.rowList diff --git a/vendor/hasql/tasty/Main.hs b/vendor/hasql/tasty/Main.hs new file mode 100644 index 0000000000..ce65b11cb8 --- /dev/null +++ b/vendor/hasql/tasty/Main.hs @@ -0,0 +1,469 @@ +module Main where + +import Contravariant.Extras +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import qualified Hasql.TestingKit.TestingDsl as Session +import qualified Main.Connection as Connection +import Main.Prelude hiding (assert) +import qualified Main.Statements as Statements +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.Tasty.Runners + +main :: IO () +main = + defaultMain tree + +tree :: TestTree +tree = + localOption (NumThreads 1) + $ testGroup + "All tests" + [ testGroup "Roundtrips" + $ let roundtrip encoder decoder input = + let session = + let statement = Statement.Statement "select $1" encoder decoder True + in Session.statement input statement + in unsafePerformIO $ do + x <- Connection.with (Session.run session) + return (Right (Right input) === x) + in [ testProperty "Array" + $ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))) + in roundtrip encoder decoder, + testProperty "2D Array" + $ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))) + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))) + in \list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list) + ], + testCase "Failed query" + $ let statement = + Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True + where + encoder = + contrazip2 + (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))) + (Encoders.param (Encoders.nonNullable Encoders.text)) + decoder = + fmap Data.Maybe.isJust (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) + session = + Session.statement ([3, 7], "a") statement + in do + x <- Connection.with (Session.run session) + assertBool (show x) $ case x of + Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True + _ -> False, + testCase "IN simulation" + $ let statement = + Statement.Statement "select true where 1 = any ($1)" encoder decoder True + where + encoder = + Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) + decoder = + fmap Data.Maybe.isJust (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) + session = + do + result1 <- Session.statement [1, 2] statement + result2 <- Session.statement [2, 3] statement + return (result1, result2) + in do + x <- Connection.with (Session.run session) + assertEqual (show x) (Right (Right (True, False))) x, + testCase "NOT IN simulation" + $ let statement = + Statement.Statement "select true where 3 <> all ($1)" encoder decoder True + where + encoder = + Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) + decoder = + fmap Data.Maybe.isJust (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) + session = + do + result1 <- Session.statement [1, 2] statement + result2 <- Session.statement [2, 3] statement + return (result1, result2) + in do + x <- Connection.with (Session.run session) + assertEqual (show x) (Right (Right (True, False))) x, + testCase "Composite decoding" + $ let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select (1, true)" + encoder = + mempty + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool))) + session = + Session.statement () statement + in do + x <- Connection.with (Session.run session) + assertEqual (show x) (Right (Right (1, True))) x, + testCase "Complex composite decoding" + $ let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select (1, true) as entity1, ('hello', 3) as entity2" + encoder = + mempty + decoder = + Decoders.singleRow + $ (,) + <$> (Decoders.column . Decoders.nonNullable) entity1 + <*> (Decoders.column . Decoders.nonNullable) entity2 + where + entity1 = + Decoders.composite + $ (,) + <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 + <*> (Decoders.field . Decoders.nonNullable) Decoders.bool + entity2 = + Decoders.composite + $ (,) + <$> (Decoders.field . Decoders.nonNullable) Decoders.text + <*> (Decoders.field . Decoders.nonNullable) Decoders.int8 + session = + Session.statement () statement + in do + x <- Connection.with (Session.run session) + assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x, + testGroup "unknownEnum" [ testCase "" $ do + res <- Session.runSessionOnLocalDb $ do + let statement = + Statement.Statement sql mempty Decoders.noResult True + where + sql = + "drop type if exists mood" + in Session.statement () statement + let statement = + Statement.Statement sql mempty Decoders.noResult True + where + sql = + "create type mood as enum ('sad', 'ok', 'happy')" + in Session.statement () statement + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1" + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum Just)) + encoder = + Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id)) + in Session.statement "ok" statement + + assertEqual "" (Right "ok") res + ], + testCase "Composite encoding" $ do + let value = + (123, 456, 789, "abc") + res <- + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1 :: pg_enum" + encoder = + Encoders.param + . Encoders.nonNullable + . Encoders.composite + . mconcat + $ [ contramap (\(a, _, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid, + contramap (\(_, a, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid, + contramap (\(_, _, a, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.float4, + contramap (\(_, _, _, a) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.name + ] + decoder = + Decoders.singleRow + $ (Decoders.column . Decoders.nonNullable . Decoders.composite) + ( (,,,) + <$> (Decoders.field . Decoders.nonNullable) Decoders.int4 + <*> (Decoders.field . Decoders.nonNullable) Decoders.int4 + <*> (Decoders.field . Decoders.nonNullable) Decoders.float4 + <*> (Decoders.field . Decoders.nonNullable) Decoders.text + ) + in Connection.with $ Session.run $ Session.statement value statement + assertEqual "" (Right (Right value)) res, + testCase "Empty array" + $ let io = + do + x <- Connection.with (Session.run session) + assertEqual (show x) (Right (Right [])) x + where + session = + Session.statement () statement + where + statement = + Statement.Statement sql encoder decoder True + where + sql = + "select array[]::int8[]" + encoder = + mempty + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))) + in io, + testCase "Failing prepared statements" + $ let io = + Connection.with (Session.run session) + >>= (assertBool <$> show <*> resultTest) + where + resultTest = + \case + Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False + _ -> True + session = + catchError session (const (pure ())) *> session + where + session = + Session.statement () statement + where + statement = + Statement.Statement sql encoder decoder True + where + sql = + "absurd" + encoder = + mempty + decoder = + Decoders.noResult + in io, + testCase "Prepared statements after error" + $ let io = + Connection.with (Session.run session) + >>= \x -> assertBool (show x) (either (const False) isRight x) + where + session = + try *> fail *> try + where + try = + Session.statement 1 statement + where + statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1 :: int8" + encoder = + Encoders.param (Encoders.nonNullable Encoders.int8) + decoder = + Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8 + fail = + catchError (Session.sql "absurd") (const (pure ())) + in io, + testCase "\"in progress after error\" bugfix" + $ let sumStatement :: Statement.Statement (Int64, Int64) Int64 + sumStatement = + Statement.Statement sql encoder decoder True + where + sql = + "select ($1 + $2)" + encoder = + contramap fst (Encoders.param (Encoders.nonNullable Encoders.int8)) + <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.int8)) + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) + sumSession :: Session.Session Int64 + sumSession = + Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end" + errorSession :: Session.Session () + errorSession = + Session.sql "asldfjsldk" + io = + Connection.with $ \c -> do + _ <- Session.run errorSession c + Session.run sumSession c + in io >>= \x -> assertBool (show x) (either (const False) isRight x), + testCase "\"another command is already in progress\" bugfix" + $ let sumStatement :: Statement.Statement (Int64, Int64) Int64 + sumStatement = + Statement.Statement sql encoder decoder True + where + sql = + "select ($1 + $2)" + encoder = + contramap fst (Encoders.param (Encoders.nonNullable Encoders.int8)) + <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.int8)) + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) + session :: Session.Session Int64 + session = + do + Session.sql "begin;" + s <- Session.statement (1, 1) sumStatement + Session.sql "end;" + return s + in Session.runSessionOnLocalDb session >>= \x -> assertEqual (show x) (Right 2) x, + testCase "Executing the same query twice" + $ pure (), + testCase "Interval Encoding" + $ let actualIO = + Session.runSessionOnLocalDb $ do + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1 = interval '10 seconds'" + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.bool) + encoder = + Encoders.param (Encoders.nonNullable Encoders.interval) + in Session.statement (10 :: DiffTime) statement + in actualIO >>= \x -> assertEqual (show x) (Right True) x, + testCase "Interval Decoding" + $ let actualIO = + Session.runSessionOnLocalDb $ do + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select interval '10 seconds'" + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.interval) + encoder = + Encoders.noParams + in Session.statement () statement + in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x, + testCase "Interval Encoding/Decoding" + $ let actualIO = + Session.runSessionOnLocalDb $ do + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1" + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.interval) + encoder = + Encoders.param (Encoders.nonNullable Encoders.interval) + in Session.statement (10 :: DiffTime) statement + in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x, + testCase "Unknown" + $ let actualIO = + Session.runSessionOnLocalDb $ do + let statement = + Statement.Statement sql mempty Decoders.noResult True + where + sql = + "drop type if exists mood" + in Session.statement () statement + let statement = + Statement.Statement sql mempty Decoders.noResult True + where + sql = + "create type mood as enum ('sad', 'ok', 'happy')" + in Session.statement () statement + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1 = ('ok' :: mood)" + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.bool) + encoder = + Encoders.param (Encoders.nonNullable Encoders.unknown) + in Session.statement "ok" statement + in actualIO >>= assertEqual "" (Right True), + testCase "Enum" + $ let actualIO = + Session.runSessionOnLocalDb $ do + let statement = + Statement.Statement sql mempty Decoders.noResult True + where + sql = + "drop type if exists mood" + in Session.statement () statement + let statement = + Statement.Statement sql mempty Decoders.noResult True + where + sql = + "create type mood as enum ('sad', 'ok', 'happy')" + in Session.statement () statement + let statement = + Statement.Statement sql encoder decoder True + where + sql = + "select ($1 :: mood)" + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum Just)) + encoder = + Encoders.param (Encoders.nonNullable (Encoders.enum id)) + in Session.statement "ok" statement + in actualIO >>= assertEqual "" (Right "ok"), + testCase "The same prepared statement used on different types" + $ let actualIO = + Session.runSessionOnLocalDb $ do + let effect1 = + Session.statement "ok" statement + where + statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1" + encoder = + Encoders.param (Encoders.nonNullable Encoders.text) + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.text) + effect2 = + Session.statement 1 statement + where + statement = + Statement.Statement sql encoder decoder True + where + sql = + "select $1" + encoder = + Encoders.param (Encoders.nonNullable Encoders.int8) + decoder = + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) + in (,) <$> effect1 <*> effect2 + in actualIO >>= assertEqual "" (Right ("ok", 1)), + testCase "Affected rows counting" + $ replicateM_ 13 + $ let actualIO = + Session.runSessionOnLocalDb $ do + dropTable + createTable + replicateM_ 100 insertRow + deleteRows <* dropTable + where + dropTable = + Session.statement () + $ Statements.plain "drop table if exists a" + createTable = + Session.statement () + $ Statements.plain "create table a (id bigserial not null, name varchar not null, primary key (id))" + insertRow = + Session.statement () + $ Statements.plain "insert into a (name) values ('a')" + deleteRows = + Session.statement () $ Statement.Statement sql mempty decoder False + where + sql = + "delete from a" + decoder = + Decoders.rowsAffected + in actualIO >>= assertEqual "" (Right 100), + testCase "Result of an auto-incremented column" + $ let actualIO = + Session.runSessionOnLocalDb $ do + Session.statement () $ Statements.plain "drop table if exists a" + Session.statement () $ Statements.plain "create table a (id serial not null, v char not null, primary key (id))" + id1 <- Session.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False + id2 <- Session.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False + Session.statement () $ Statements.plain "drop table if exists a" + pure (id1, id2) + in assertEqual "" (Right (1, 2)) =<< actualIO, + testCase "List decoding" + $ let actualIO = + Session.runSessionOnLocalDb $ Session.statement () Statements.selectList + in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO + ] diff --git a/vendor/hasql/tasty/Main/Connection.hs b/vendor/hasql/tasty/Main/Connection.hs new file mode 100644 index 0000000000..90503659b2 --- /dev/null +++ b/vendor/hasql/tasty/Main/Connection.hs @@ -0,0 +1,16 @@ +module Main.Connection where + +import qualified Hasql.Connection as HC +import qualified Hasql.TestingKit.Constants as Constants +import Main.Prelude + +with :: (HC.Connection -> IO a) -> IO (Either HC.ConnectionError a) +with handler = + runExceptT $ acquire >>= \connection -> use connection <* release connection + where + acquire = + ExceptT $ HC.acquire Constants.localConnectionSettings + use connection = + lift $ handler connection + release connection = + lift $ HC.release connection diff --git a/vendor/hasql/tasty/Main/Prelude.hs b/vendor/hasql/tasty/Main/Prelude.hs new file mode 100644 index 0000000000..6d93af5402 --- /dev/null +++ b/vendor/hasql/tasty/Main/Prelude.hs @@ -0,0 +1,6 @@ +module Main.Prelude + ( module Exports, + ) +where + +import Prelude as Exports diff --git a/vendor/hasql/tasty/Main/Statements.hs b/vendor/hasql/tasty/Main/Statements.hs new file mode 100644 index 0000000000..a01338ad07 --- /dev/null +++ b/vendor/hasql/tasty/Main/Statements.hs @@ -0,0 +1,33 @@ +module Main.Statements where + +import qualified Hasql.Decoders as HD +import qualified Hasql.Statement as HQ +import Main.Prelude + +plain :: ByteString -> HQ.Statement () () +plain sql = + HQ.Statement sql mempty HD.noResult False + +dropType :: ByteString -> HQ.Statement () () +dropType name = + plain + $ "drop type if exists " + <> name + +createEnum :: ByteString -> [ByteString] -> HQ.Statement () () +createEnum name values = + plain + $ "create type " + <> name + <> " as enum (" + <> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) + <> ")" + +selectList :: HQ.Statement () ([] (Int64, Int64)) +selectList = + HQ.Statement sql mempty decoder True + where + sql = + "values (1,2), (3,4), (5,6)" + decoder = + HD.rowList ((,) <$> (HD.column . HD.nonNullable) HD.int8 <*> (HD.column . HD.nonNullable) HD.int8) diff --git a/vendor/hasql/testing-kit/Hasql/TestingKit/Constants.hs b/vendor/hasql/testing-kit/Hasql/TestingKit/Constants.hs new file mode 100644 index 0000000000..45a940f36e --- /dev/null +++ b/vendor/hasql/testing-kit/Hasql/TestingKit/Constants.hs @@ -0,0 +1,18 @@ +module Hasql.TestingKit.Constants where + +import qualified Hasql.Connection.Setting as Setting +import qualified Hasql.Connection.Setting.Connection as Setting.Connection +import qualified Hasql.Connection.Setting.Connection.Param as Setting.Connection.Component + +localConnectionSettings :: [Setting.Setting] +localConnectionSettings = + [ Setting.connection + ( Setting.Connection.params + [ Setting.Connection.Component.host "localhost", + Setting.Connection.Component.port 5432, + Setting.Connection.Component.user "postgres", + Setting.Connection.Component.password "postgres", + Setting.Connection.Component.dbname "postgres" + ] + ) + ] diff --git a/vendor/hasql/testing-kit/Hasql/TestingKit/Preludes/Base.hs b/vendor/hasql/testing-kit/Hasql/TestingKit/Preludes/Base.hs new file mode 100644 index 0000000000..b26f08143e --- /dev/null +++ b/vendor/hasql/testing-kit/Hasql/TestingKit/Preludes/Base.hs @@ -0,0 +1,19 @@ +module Hasql.TestingKit.Preludes.Base + ( module Exports, + ) +where + +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Except as Exports (Except, + ExceptT (ExceptT), + catchE, except, + finallyE, mapExcept, + mapExceptT, runExcept, + runExceptT, throwE, + withExcept, withExceptT) +import Data.Bifunctor as Exports +import Data.ByteString as Exports (ByteString) +import Data.Functor.Contravariant as Exports +import Data.Int as Exports +import Data.UUID as Exports (UUID) +import Prelude as Exports diff --git a/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs b/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs new file mode 100644 index 0000000000..e78f180dd0 --- /dev/null +++ b/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs @@ -0,0 +1,43 @@ +module Hasql.TestingKit.Statements.BrokenSyntax where + +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Pipeline as Pipeline +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import Hasql.TestingKit.Preludes.Base + +data Params = Params + { start :: Int64, + end :: Int64 + } + +type Result = [Int64] + +session :: Bool -> Params -> Session.Session Result +session prepared params = + Session.statement params (statement prepared) + +pipeline :: Bool -> Params -> Pipeline.Pipeline Result +pipeline prepared params = + Pipeline.statement params (statement prepared) + +statement :: Bool -> Statement.Statement Params Result +statement = + Statement.Statement sql encoder decoder + +sql :: ByteString +sql = + "S" + +encoder :: Encoders.Params Params +encoder = + mconcat + [ start >$< Encoders.param (Encoders.nonNullable Encoders.int8), + end >$< Encoders.param (Encoders.nonNullable Encoders.int8) + ] + +decoder :: Decoders.Result Result +decoder = + Decoders.rowList + (Decoders.column (Decoders.nonNullable Decoders.int8)) diff --git a/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs b/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs new file mode 100644 index 0000000000..a86f376349 --- /dev/null +++ b/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs @@ -0,0 +1,43 @@ +module Hasql.TestingKit.Statements.GenerateSeries where + +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Pipeline as Pipeline +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import Hasql.TestingKit.Preludes.Base + +data Params = Params + { start :: Int64, + end :: Int64 + } + +type Result = [Int64] + +session :: Bool -> Params -> Session.Session Result +session prepared params = + Session.statement params (statement prepared) + +pipeline :: Bool -> Params -> Pipeline.Pipeline Result +pipeline prepared params = + Pipeline.statement params (statement prepared) + +statement :: Bool -> Statement.Statement Params Result +statement = + Statement.Statement sql encoder decoder + +sql :: ByteString +sql = + "SELECT generate_series($1, $2)" + +encoder :: Encoders.Params Params +encoder = + mconcat + [ start >$< Encoders.param (Encoders.nonNullable Encoders.int8), + end >$< Encoders.param (Encoders.nonNullable Encoders.int8) + ] + +decoder :: Decoders.Result Result +decoder = + Decoders.rowList + (Decoders.column (Decoders.nonNullable Decoders.int8)) diff --git a/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs b/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs new file mode 100644 index 0000000000..5548c36f9d --- /dev/null +++ b/vendor/hasql/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs @@ -0,0 +1,43 @@ +module Hasql.TestingKit.Statements.WrongDecoder where + +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Pipeline as Pipeline +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import Hasql.TestingKit.Preludes.Base + +data Params = Params + { start :: Int64, + end :: Int64 + } + +type Result = [UUID] + +session :: Bool -> Params -> Session.Session Result +session prepared params = + Session.statement params (statement prepared) + +pipeline :: Bool -> Params -> Pipeline.Pipeline Result +pipeline prepared params = + Pipeline.statement params (statement prepared) + +statement :: Bool -> Statement.Statement Params Result +statement = + Statement.Statement sql encoder decoder + +sql :: ByteString +sql = + "SELECT generate_series($1, $2)" + +encoder :: Encoders.Params Params +encoder = + mconcat + [ start >$< Encoders.param (Encoders.nonNullable Encoders.int8), + end >$< Encoders.param (Encoders.nonNullable Encoders.int8) + ] + +decoder :: Decoders.Result Result +decoder = + Decoders.rowList + (Decoders.column (Decoders.nonNullable Decoders.uuid)) diff --git a/vendor/hasql/testing-kit/Hasql/TestingKit/TestingDsl.hs b/vendor/hasql/testing-kit/Hasql/TestingKit/TestingDsl.hs new file mode 100644 index 0000000000..c9244219f1 --- /dev/null +++ b/vendor/hasql/testing-kit/Hasql/TestingKit/TestingDsl.hs @@ -0,0 +1,55 @@ +module Hasql.TestingKit.TestingDsl + ( -- * Errors + Error (..), + Session.SessionError (..), + Session.CommandError (..), + Session.ResultError (..), + Session.RowError (..), + + -- * Abstractions + Session.Session, + Pipeline.Pipeline, + Statement.Statement (..), + + -- * Execution + runSessionOnLocalDb, + runPipelineOnLocalDb, + runStatementInSession, + runPipelineInSession, + ) +where + +import qualified Hasql.Connection as Connection +import qualified Hasql.Pipeline as Pipeline +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import qualified Hasql.TestingKit.Constants as Constants +import Hasql.TestingKit.Preludes.Base + +data Error + = ConnectionError Connection.ConnectionError + | SessionError Session.SessionError + deriving (Show, Eq) + +runSessionOnLocalDb :: Session.Session a -> IO (Either Error a) +runSessionOnLocalDb session = + runExceptT $ acquire >>= \connection -> use connection <* release connection + where + acquire = + ExceptT (first ConnectionError <$> Connection.acquire Constants.localConnectionSettings) + use connection = + ExceptT (first SessionError <$> Session.run session connection) + release connection = + lift $ Connection.release connection + +runPipelineOnLocalDb :: Pipeline.Pipeline a -> IO (Either Error a) +runPipelineOnLocalDb = + runSessionOnLocalDb . Session.pipeline + +runStatementInSession :: Statement.Statement a b -> a -> Session.Session b +runStatementInSession statement params = + Session.statement params statement + +runPipelineInSession :: Pipeline.Pipeline a -> Session.Session a +runPipelineInSession = + Session.pipeline diff --git a/vendor/hasql/threads-test/Main.hs b/vendor/hasql/threads-test/Main.hs new file mode 100644 index 0000000000..4446396252 --- /dev/null +++ b/vendor/hasql/threads-test/Main.hs @@ -0,0 +1,52 @@ +module Main where + +import qualified Hasql.Connection +import qualified Hasql.Connection.Setting +import qualified Hasql.Connection.Setting.Connection +import qualified Hasql.Connection.Setting.Connection.Param +import qualified Hasql.Session +import qualified Main.Statements as Statements +import Prelude + +main :: IO () +main = + acquire >>= use + where + acquire = + (,) <$> acquire <*> acquire + where + acquire = + either (fail . show) return =<< Hasql.Connection.acquire connectionSettings + where + connectionSettings = + [ Hasql.Connection.Setting.connection + ( Hasql.Connection.Setting.Connection.params + [ Hasql.Connection.Setting.Connection.Param.host "localhost", + Hasql.Connection.Setting.Connection.Param.port 5432, + Hasql.Connection.Setting.Connection.Param.user "postgres", + Hasql.Connection.Setting.Connection.Param.password "postgres", + Hasql.Connection.Setting.Connection.Param.dbname "postgres" + ] + ) + ] + use (connection1, connection2) = + do + beginVar <- newEmptyMVar + finishVar <- newEmptyMVar + forkIO $ do + traceM "1: in" + putMVar beginVar () + session connection1 (Hasql.Session.statement 0.2 Statements.selectSleep) + traceM "1: out" + void (tryPutMVar finishVar False) + forkIO $ do + takeMVar beginVar + traceM "2: in" + session connection2 (Hasql.Session.statement 0.1 Statements.selectSleep) + traceM "2: out" + void (tryPutMVar finishVar True) + bool exitFailure exitSuccess . traceShowId =<< takeMVar finishVar + where + session connection session = + Hasql.Session.run session connection + >>= either (fail . show) return diff --git a/vendor/hasql/threads-test/Main/Statements.hs b/vendor/hasql/threads-test/Main/Statements.hs new file mode 100644 index 0000000000..bc9966e0f9 --- /dev/null +++ b/vendor/hasql/threads-test/Main/Statements.hs @@ -0,0 +1,17 @@ +module Main.Statements where + +import qualified Hasql.Decoders as D +import qualified Hasql.Encoders as E +import Hasql.Statement +import Prelude + +selectSleep :: Statement Double () +selectSleep = + Statement sql encoder decoder True + where + sql = + "select pg_sleep($1)" + encoder = + E.param (E.nonNullable E.float8) + decoder = + D.noResult