diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,15 +1,14 @@ module Main where -import qualified Data.Vector as F -import Gauge -import Gauge.Main +import Criterion +import Criterion.Main import qualified Hasql.Connection as A import qualified Hasql.Decoders as D -import qualified Hasql.Encoders as E import qualified Hasql.Session as B import qualified Hasql.Statement as C import Prelude +main :: IO () main = do Right connection <- acquireConnection diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql -version: 1.6.4 +version: 1.6.4.1 category: Hasql, Database, PostgreSQL synopsis: An efficient PostgreSQL driver with a flexible mapping API description: @@ -24,8 +24,7 @@ type: git location: git://github.com/nikita-volkov/hasql.git -library - hs-source-dirs: library +common base default-extensions: NoImplicitPrelude NoMonomorphismRestriction @@ -66,6 +65,19 @@ UnboxedTuples default-language: Haskell2010 + +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 + import: base + hs-source-dirs: library exposed-modules: Hasql.Connection Hasql.Decoders @@ -74,26 +86,26 @@ Hasql.Statement other-modules: - Hasql.Private.Commands - Hasql.Private.Connection - Hasql.Private.Decoders - Hasql.Private.Decoders.Array - Hasql.Private.Decoders.Composite - Hasql.Private.Decoders.Result - Hasql.Private.Decoders.Results - Hasql.Private.Decoders.Row - Hasql.Private.Decoders.Value - Hasql.Private.Encoders - Hasql.Private.Encoders.Array - Hasql.Private.Encoders.Params - Hasql.Private.Encoders.Value - Hasql.Private.Errors - Hasql.Private.IO - Hasql.Private.Prelude - Hasql.Private.PreparedStatementRegistry - Hasql.Private.PTI - Hasql.Private.Session - Hasql.Private.Settings + Hasql.Commands + 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.Encoders.All + Hasql.Encoders.Array + Hasql.Encoders.Params + Hasql.Encoders.Value + Hasql.Errors + Hasql.IO + Hasql.Prelude + Hasql.PreparedStatementRegistry + Hasql.PTI + Hasql.Session.Core + Hasql.Settings build-depends: , aeson >=2 && <3 @@ -119,49 +131,10 @@ , vector >=0.10 && <0.14 test-suite tasty - type: exitcode-stdio-1.0 - hs-source-dirs: tasty - main-is: Main.hs - default-extensions: - NoImplicitPrelude - NoMonomorphismRestriction - Arrows - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - EmptyDataDecls - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - LambdaCase - LiberalTypeSynonyms - MagicHash - MultiParamTypeClasses - MultiWayIf - OverloadedStrings - ParallelListComp - PatternGuards - QuasiQuotes - RankNTypes - RecordWildCards - RoleAnnotations - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeOperators - UnboxedTuples - - default-language: Haskell2010 + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: tasty + main-is: Main.hs other-modules: Main.Connection Main.DSL @@ -178,152 +151,31 @@ , tasty-quickcheck >=0.9 && <0.11 test-suite threads-test - type: exitcode-stdio-1.0 - hs-source-dirs: threads-test - main-is: Main.hs - default-extensions: - NoImplicitPrelude - NoMonomorphismRestriction - Arrows - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - EmptyDataDecls - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - LambdaCase - LiberalTypeSynonyms - MagicHash - MultiParamTypeClasses - MultiWayIf - OverloadedStrings - ParallelListComp - PatternGuards - QuasiQuotes - RankNTypes - RecordWildCards - RoleAnnotations - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeOperators - UnboxedTuples - - default-language: Haskell2010 - other-modules: Main.Statements - ghc-options: -O2 -threaded -with-rtsopts=-N + 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 - type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks - main-is: Main.hs - default-extensions: - NoImplicitPrelude - NoMonomorphismRestriction - Arrows - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - EmptyDataDecls - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - LambdaCase - LiberalTypeSynonyms - MagicHash - MultiParamTypeClasses - MultiWayIf - OverloadedStrings - ParallelListComp - PatternGuards - QuasiQuotes - RankNTypes - RecordWildCards - RoleAnnotations - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeOperators - UnboxedTuples - - default-language: Haskell2010 - ghc-options: - -O2 -threaded -with-rtsopts=-N -rtsopts -funbox-strict-fields - + import: executable + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs build-depends: - , gauge >=0.2.5 && <0.3 + , criterion >=1.6 && <2 , hasql , rerebase <2 test-suite profiling - type: exitcode-stdio-1.0 - hs-source-dirs: profiling - main-is: Main.hs - default-extensions: - NoImplicitPrelude - NoMonomorphismRestriction - Arrows - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - EmptyDataDecls - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - LambdaCase - LiberalTypeSynonyms - MagicHash - MultiParamTypeClasses - MultiWayIf - OverloadedStrings - ParallelListComp - PatternGuards - QuasiQuotes - RankNTypes - RecordWildCards - RoleAnnotations - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeFamilies - TypeOperators - UnboxedTuples - - default-language: Haskell2010 - ghc-options: -O2 -threaded -rtsopts + 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 diff --git a/library/Hasql/Commands.hs b/library/Hasql/Commands.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Commands.hs @@ -0,0 +1,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/library/Hasql/Connection.hs b/library/Hasql/Connection.hs --- a/library/Hasql/Connection.hs +++ b/library/Hasql/Connection.hs @@ -11,5 +11,5 @@ ) where -import Hasql.Private.Connection -import Hasql.Private.Settings +import Hasql.Connection.Core +import Hasql.Settings diff --git a/library/Hasql/Connection/Core.hs b/library/Hasql/Connection/Core.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Connection/Core.hs @@ -0,0 +1,50 @@ +-- | +-- This module provides a low-level effectful API dealing with the connections to the database. +module Hasql.Connection.Core where + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.IO as IO +import Hasql.Prelude +import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry +import qualified Hasql.Settings as Settings + +-- | +-- A single connection to the database. +data Connection + = Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry + +-- | +-- Possible details of the connection acquistion error. +type ConnectionError = + Maybe ByteString + +-- | +-- Acquire a connection using the provided settings encoded according to the PostgreSQL format. +acquire :: Settings.Settings -> IO (Either ConnectionError Connection) +acquire settings = + {-# SCC "acquire" #-} + runExceptT $ do + pqConnection <- lift (IO.acquireConnection settings) + 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 pqConnectionRef integerDatetimes registry) + +-- | +-- 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/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs --- a/library/Hasql/Decoders.hs +++ b/library/Hasql/Decoders.hs @@ -69,4 +69,4 @@ ) where -import Hasql.Private.Decoders +import Hasql.Decoders.All diff --git a/library/Hasql/Decoders/All.hs b/library/Hasql/Decoders/All.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoders/All.hs @@ -0,0 +1,407 @@ +-- | +-- A DSL for declaration of result decoders. +module Hasql.Decoders.All where + +import qualified Data.Aeson as Aeson +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 Network.IP.Addr as NetworkIp +import qualified PostgreSQL.Binary.Decoding as A + +-- * Result + +-- | +-- Decoder of a query result. +newtype Result a = Result (Results.Results a) deriving (Functor) + +-- | +-- Decode no value from the result. +-- +-- Useful for statements like @INSERT@ or @CREATE@. +{-# 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) + +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 (NetworkIp.NetAddr NetworkIp.IP) +inet = Value (Value.decoder (const A.inet)) + +-- | +-- 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))) + +-- | +-- 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.Value (\b -> A.refine fn (Value.run v b))) + +-- | +-- 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/library/Hasql/Decoders/Array.hs b/library/Hasql/Decoders/Array.hs new file mode 100644 --- /dev/null +++ b/library/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/library/Hasql/Decoders/Composite.hs b/library/Hasql/Decoders/Composite.hs new file mode 100644 --- /dev/null +++ b/library/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/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoders/Result.hs @@ -0,0 +1,228 @@ +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 Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Decoders.Row as Row +import Hasql.Errors +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) env = + runExceptT (runReaderT reader env) + +{-# INLINE noResult #-} +noResult :: Result () +noResult = + checkExecStatus $ \case + LibPQ.CommandOk -> True + LibPQ.TuplesOk -> True + _ -> False + +{-# INLINE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + do + checkExecStatus $ \case + LibPQ.CommandOk -> True + _ -> False + Result + $ ReaderT + $ \(_, result) -> + 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 = + mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) + $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes + +{-# INLINE checkExecStatus #-} +checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () +checkExecStatus predicate = + {-# SCC "checkExecStatus" #-} + do + status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result + unless (predicate status) $ do + case status of + LibPQ.BadResponse -> serverError + LibPQ.NonfatalError -> serverError + LibPQ.FatalError -> serverError + LibPQ.EmptyQuery -> return () + _ -> Result $ lift $ ExceptT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) + +{-# INLINE serverError #-} +serverError :: Result () +serverError = + Result + $ ReaderT + $ \(_, result) -> ExceptT $ do + code <- + fmap fold + $ LibPQ.resultErrorField result LibPQ.DiagSqlstate + message <- + fmap 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 $ \case + LibPQ.TuplesOk -> True + _ -> False + 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 (fmap Just . mapLeft 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 $ \case + LibPQ.TuplesOk -> True + _ -> False + 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 + fmap (mapLeft 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 $ \case + LibPQ.TuplesOk -> True + _ -> False + 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 $ \case + LibPQ.TuplesOk -> True + _ -> False + 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 (\acc -> step acc x) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldr #-} +foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a +foldr step init rowDec = + {-# SCC "foldr" #-} + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result + $ ReaderT + $ \(integerDatetimes, result) -> 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 (\acc -> step x acc) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoders/Results.hs @@ -0,0 +1,94 @@ +-- | +-- 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 Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Decoders.Result as Result +import Hasql.Errors +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) + +{-# INLINE run #-} +run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a) +run (Results stack) env = + runExceptT (runReaderT stack env) + +{-# 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 -> + mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) + Nothing -> + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINE getResult #-} +getResult :: Results LibPQ.Result +getResult = + Results + $ ReaderT + $ \(_, connection) -> ExceptT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> pure (Right result) + Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINE getResultMaybe #-} +getResultMaybe :: Results (Maybe LibPQ.Result) +getResultMaybe = + Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection + +{-# INLINE dropRemainders #-} +dropRemainders :: Results () +dropRemainders = + {-# SCC "dropRemainders" #-} + Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection + where + loop integerDatetimes connection = + getResultMaybe >>= Prelude.maybe (pure ()) onResult + where + getResultMaybe = + lift $ LibPQ.getResult connection + onResult result = + loop integerDatetimes connection <* checkErrors + where + checkErrors = + ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result) + +refine :: (a -> Either Text b) -> Results a -> Results b +refine refiner results = Results + $ ReaderT + $ \env -> ExceptT $ do + resultEither <- run results env + return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner diff --git a/library/Hasql/Decoders/Row.hs b/library/Hasql/Decoders/Row.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoders/Row.hs @@ -0,0 +1,68 @@ +module Hasql.Decoders.Row where + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Decoders.Value as Value +import Hasql.Errors +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 + $ mapLeft 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/library/Hasql/Decoders/Value.hs b/library/Hasql/Decoders/Value.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Decoders/Value.hs @@ -0,0 +1,24 @@ +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) + +{-# INLINE run #-} +run :: Value a -> Bool -> A.Value a +run (Value imp) integerDatetimes = + imp integerDatetimes + +{-# 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 diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -60,4 +60,4 @@ ) where -import Hasql.Private.Encoders +import Hasql.Encoders.All diff --git a/library/Hasql/Encoders/All.hs b/library/Hasql/Encoders/All.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoders/All.hs @@ -0,0 +1,423 @@ +-- | +-- 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 Hasql.Encoders.Array as Array +import qualified Hasql.Encoders.Params as Params +import qualified Hasql.Encoders.Value as Value +import qualified Hasql.PTI as PTI +import Hasql.Prelude hiding (bool) +import qualified Hasql.Prelude as Prelude +import qualified Network.IP.Addr as NetworkIp +import qualified PostgreSQL.Binary.Encoding as A +import qualified Text.Builder 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, Decidable, 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 (NetworkIp.NetAddr NetworkIp.IP) +inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet)) + +-- | +-- 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)) + +-- | +-- 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.Builder]) + +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 arrayOID encode print)) -> + Composite + (\val idt -> A.field (PTI.oidWord32 elementOID) (encode idt val)) + (\val -> [print val]) + Nullable (Value (Value.Value elementOID arrayOID encode print)) -> + Composite + ( \val idt -> case val of + Nothing -> A.nullField (PTI.oidWord32 elementOID) + Just val -> A.field (PTI.oidWord32 elementOID) (encode idt val) + ) + ( \val -> + case val of + Nothing -> ["NULL"] + Just val -> [print val] + ) diff --git a/library/Hasql/Encoders/Array.hs b/library/Hasql/Encoders/Array.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoders/Array.hs @@ -0,0 +1,44 @@ +module Hasql.Encoders.Array where + +import qualified Hasql.PTI as B +import Hasql.Prelude +import qualified PostgreSQL.Binary.Encoding as A +import qualified Text.Builder as C + +data Array a + = Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.Builder) + +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.Builder) -> 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.Builder) -> 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.null builder + then C.char '[' <> elRenderer el + else builder <> C.string ", " <> elRenderer el + in fold step mempty els + in if C.null folded + then C.string "[]" + else folded <> C.char ']' + in Array valueOID arrayOID encoder renderer diff --git a/library/Hasql/Encoders/Params.hs b/library/Hasql/Encoders/Params.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoders/Params.hs @@ -0,0 +1,31 @@ +module Hasql.Encoders.Params where + +import qualified Database.PostgreSQL.LibPQ as A +import qualified Hasql.Encoders.Value as C +import qualified Hasql.PTI as D +import Hasql.Prelude +import qualified PostgreSQL.Binary.Encoding as B +import qualified Text.Builder as E + +-- | +-- Encoder of some representation of a parameters product. +newtype Params a + = Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +value :: C.Value a -> Params a +value = + contramap Just . nullableValue + +nullableValue :: C.Value a -> Params (Maybe a) +nullableValue (C.Value valueOID arrayOID encode render) = + Params + $ Op + $ \input -> + let D.OID _ pqOid format = + valueOID + encoder env = + fmap (B.encodingBytes . encode env) input + rendering = + maybe "null" (E.run . render) input + in pure (pqOid, format, encoder, rendering) diff --git a/library/Hasql/Encoders/Value.hs b/library/Hasql/Encoders/Value.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Encoders/Value.hs @@ -0,0 +1,24 @@ +module Hasql.Encoders.Value where + +import qualified Hasql.PTI as PTI +import Hasql.Prelude +import qualified PostgreSQL.Binary.Encoding as B +import qualified Text.Builder as C + +data Value a + = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder) + +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.Builder) -> 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/library/Hasql/Errors.hs b/library/Hasql/Errors.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Errors.hs @@ -0,0 +1,147 @@ +-- | +-- 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.Errors where + +import qualified Data.ByteString.Char8 as BC +import Hasql.Prelude + +-- | +-- An error during the execution of a query. +-- Comes packed with the query template and a textual representation of the provided params. +data QueryError + = QueryError ByteString [Text] CommandError + deriving (Show, Eq, Typeable) + +instance Exception QueryError where + displayException (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: " + <> case commandError of + ClientError (Just message) -> "Client error: " <> show message + ClientError Nothing -> "Unknown client error" + ResultError resultError -> case resultError of + ServerError code message details hint position -> + "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 -> + "Row error: " <> show row <> ":" <> 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/library/Hasql/IO.hs b/library/Hasql/IO.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/IO.hs @@ -0,0 +1,162 @@ +-- | +-- An API of low-level IO operations. +module Hasql.IO where + +import qualified Database.PostgreSQL.LibPQ as LibPQ +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 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 connection = + LibPQ.finish connection + +{-# INLINE checkConnectionStatus #-} +checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString)) +checkConnectionStatus c = + do + s <- LibPQ.status c + case s of + LibPQ.ConnectionOk -> return Nothing + _ -> fmap Just (LibPQ.errorMessage c) + +{-# INLINE checkServerVersion #-} +checkServerVersion :: LibPQ.Connection -> IO (Maybe Int) +checkServerVersion c = + fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c) + +{-# INLINE getIntegerDatetimes #-} +getIntegerDatetimes :: LibPQ.Connection -> IO Bool +getIntegerDatetimes c = + fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes" + where + decodeValue = + \case + Just "on" -> True + _ -> False + +{-# INLINE initConnection #-} +initConnection :: LibPQ.Connection -> IO () +initConnection c = + void $ LibPQ.exec c (Commands.asBytes (Commands.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 (integerDatetimes, connection) + dropRemainders = + ResultsDecoders.run ResultsDecoders.dropRemainders (integerDatetimes, connection) + +{-# 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 wordOIDList + where + wordOIDList = + map (\(LibPQ.Oid x) -> fromIntegral x) oidList + onNewRemoteKey key = + do + sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) + let resultsDecoder = + if sent + then ResultsDecoders.single ResultDecoders.noResult + else ResultsDecoders.clientError + fmap resultsMapping $ getResults connection undefined resultsDecoder + where + 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 -> fmap (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 (ParamsEncoders.Params (Op encoderOp)) input = + let (oidList, valueAndFormatList) = + let step (oid, format, encoder, _) ~(oidList, bytesAndFormatList) = + (,) + (oid : oidList) + (fmap (\bytes -> (bytes, format)) (encoder integerDatetimes) : bytesAndFormatList) + in foldr step ([], []) (encoderOp input) + in runExceptT $ do + key <- ExceptT $ getPreparedStatementKey connection registry template oidList + ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary + +{-# INLINE sendUnpreparedParametricStatement #-} +sendUnpreparedParametricStatement :: + LibPQ.Connection -> + Bool -> + ByteString -> + ParamsEncoders.Params a -> + a -> + IO (Either CommandError ()) +sendUnpreparedParametricStatement connection integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input = + let params = + let step (oid, format, encoder, _) acc = + ((,,) <$> pure oid <*> encoder integerDatetimes <*> pure format) : acc + in foldr step [] (encoderOp input) + in checkedSend connection $ LibPQ.sendQueryParams connection template params 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/library/Hasql/PTI.hs b/library/Hasql/PTI.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/PTI.hs @@ -0,0 +1,230 @@ +module Hasql.PTI where + +import qualified Database.PostgreSQL.LibPQ 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) + +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) + +int8 :: PTI +int8 = mkPTI LibPQ.Binary 20 (Just 1016) + +int8range :: PTI +int8range = mkPTI LibPQ.Binary 3926 (Just 3927) + +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) + +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) + +tstzrange :: PTI +tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911) + +tsvector :: PTI +tsvector = mkPTI LibPQ.Binary 3614 (Just 3643) + +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/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Prelude.hs @@ -0,0 +1,137 @@ +module Hasql.Prelude + ( module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + forMToZero_, + forMFromZero_, + strictCons, + mapLeft, + ) +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, 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.DList as Exports (DList) +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.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.IORef as Exports +import Data.Int 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.Profunctor.Unsafe as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.Scientific as Exports (Scientific) +import Data.Semigroup as Exports hiding (First (..), Last (..)) +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.UUID as Exports (UUID) +import Data.Unique as Exports +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 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 Prelude as Exports hiding (Read, all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) + +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 -> if n >= 0 then f n *> loop (pred n) else pure () + +{-# INLINE forMFromZero_ #-} +forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m () +forMFromZero_ !endN f = + ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure () + +{-# INLINE strictCons #-} +strictCons :: a -> [a] -> [a] +strictCons !a b = + let !c = a : b in c + +{-# INLINE mapLeft #-} +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f = + either (Left . f) Right diff --git a/library/Hasql/PreparedStatementRegistry.hs b/library/Hasql/PreparedStatementRegistry.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/PreparedStatementRegistry.hs @@ -0,0 +1,53 @@ +module Hasql.PreparedStatementRegistry + ( PreparedStatementRegistry, + new, + update, + LocalKey (..), + ) +where + +import qualified ByteString.StrictBuilder as B +import qualified Data.HashTable.IO as A +import Hasql.Prelude hiding (lookup) + +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 + +-- | +-- Local statement key. +data LocalKey + = LocalKey !ByteString ![Word32] + deriving (Show, Eq) + +instance Hashable LocalKey where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (LocalKey template types) = + hashWithSalt salt template diff --git a/library/Hasql/Private/Commands.hs b/library/Hasql/Private/Commands.hs deleted file mode 100644 --- a/library/Hasql/Private/Commands.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hasql.Private.Commands - ( Commands, - asBytes, - setEncodersToUTF8, - setMinClientMessagesToWarning, - ) -where - -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL -import Hasql.Private.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/library/Hasql/Private/Connection.hs b/library/Hasql/Private/Connection.hs deleted file mode 100644 --- a/library/Hasql/Private/Connection.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | --- This module provides a low-level effectful API dealing with the connections to the database. -module Hasql.Private.Connection where - -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Private.IO as IO -import Hasql.Private.Prelude -import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry -import qualified Hasql.Private.Settings as Settings - --- | --- A single connection to the database. -data Connection - = Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry - --- | --- Possible details of the connection acquistion error. -type ConnectionError = - Maybe ByteString - --- | --- Acquire a connection using the provided settings encoded according to the PostgreSQL format. -acquire :: Settings.Settings -> IO (Either ConnectionError Connection) -acquire settings = - {-# SCC "acquire" #-} - runExceptT $ do - pqConnection <- lift (IO.acquireConnection settings) - 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 pqConnectionRef integerDatetimes registry) - --- | --- 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/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders.hs +++ /dev/null @@ -1,407 +0,0 @@ --- | --- A DSL for declaration of result decoders. -module Hasql.Private.Decoders where - -import qualified Data.Aeson as Aeson -import qualified Data.Vector.Generic as GenericVector -import qualified Hasql.Private.Decoders.Array as Array -import qualified Hasql.Private.Decoders.Composite as Composite -import qualified Hasql.Private.Decoders.Result as Result -import qualified Hasql.Private.Decoders.Results as Results -import qualified Hasql.Private.Decoders.Row as Row -import qualified Hasql.Private.Decoders.Value as Value -import Hasql.Private.Prelude hiding (bool, maybe) -import qualified Hasql.Private.Prelude as Prelude -import qualified Network.IP.Addr as NetworkIp -import qualified PostgreSQL.Binary.Decoding as A - --- * Result - --- | --- Decoder of a query result. -newtype Result a = Result (Results.Results a) deriving (Functor) - --- | --- Decode no value from the result. --- --- Useful for statements like @INSERT@ or @CREATE@. -{-# 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) - -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 (NetworkIp.NetAddr NetworkIp.IP) -inet = Value (Value.decoder (const A.inet)) - --- | --- 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))) - --- | --- 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.Value (\b -> A.refine fn (Value.run v b))) - --- | --- 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/library/Hasql/Private/Decoders/Array.hs b/library/Hasql/Private/Decoders/Array.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders/Array.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Hasql.Private.Decoders.Array where - -import Hasql.Private.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/library/Hasql/Private/Decoders/Composite.hs b/library/Hasql/Private/Decoders/Composite.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders/Composite.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Hasql.Private.Decoders.Composite where - -import Hasql.Private.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/library/Hasql/Private/Decoders/Result.hs b/library/Hasql/Private/Decoders/Result.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders/Result.hs +++ /dev/null @@ -1,228 +0,0 @@ -module Hasql.Private.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 Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Private.Decoders.Row as Row -import Hasql.Private.Errors -import Hasql.Private.Prelude hiding (many, maybe) -import qualified Hasql.Private.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) env = - runExceptT (runReaderT reader env) - -{-# INLINE noResult #-} -noResult :: Result () -noResult = - checkExecStatus $ \case - LibPQ.CommandOk -> True - LibPQ.TuplesOk -> True - _ -> False - -{-# INLINE rowsAffected #-} -rowsAffected :: Result Int64 -rowsAffected = - do - checkExecStatus $ \case - LibPQ.CommandOk -> True - _ -> False - Result - $ ReaderT - $ \(_, result) -> - 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 = - mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) - $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes - -{-# INLINE checkExecStatus #-} -checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () -checkExecStatus predicate = - {-# SCC "checkExecStatus" #-} - do - status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result - unless (predicate status) $ do - case status of - LibPQ.BadResponse -> serverError - LibPQ.NonfatalError -> serverError - LibPQ.FatalError -> serverError - LibPQ.EmptyQuery -> return () - _ -> Result $ lift $ ExceptT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) - -{-# INLINE serverError #-} -serverError :: Result () -serverError = - Result - $ ReaderT - $ \(_, result) -> ExceptT $ do - code <- - fmap fold - $ LibPQ.resultErrorField result LibPQ.DiagSqlstate - message <- - fmap 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 $ \case - LibPQ.TuplesOk -> True - _ -> False - 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 (fmap Just . mapLeft 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 $ \case - LibPQ.TuplesOk -> True - _ -> False - 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 - fmap (mapLeft 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 $ \case - LibPQ.TuplesOk -> True - _ -> False - 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 $ \case - LibPQ.TuplesOk -> True - _ -> False - 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 (\acc -> step acc x) - readIORef failureRef >>= \case - Nothing -> Right <$> readIORef accRef - Just x -> pure (Left x) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral - -{-# INLINE foldr #-} -foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a -foldr step init rowDec = - {-# SCC "foldr" #-} - do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False - Result - $ ReaderT - $ \(integerDatetimes, result) -> 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 (\acc -> step x acc) - readIORef failureRef >>= \case - Nothing -> Right <$> readIORef accRef - Just x -> pure (Left x) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral diff --git a/library/Hasql/Private/Decoders/Results.hs b/library/Hasql/Private/Decoders/Results.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders/Results.hs +++ /dev/null @@ -1,94 +0,0 @@ --- | --- 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.Private.Decoders.Results where - -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Private.Decoders.Result as Result -import Hasql.Private.Errors -import Hasql.Private.Prelude hiding (many, maybe) -import qualified Hasql.Private.Prelude as Prelude - -newtype Results a - = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a) - deriving (Functor, Applicative, Monad) - -{-# INLINE run #-} -run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a) -run (Results stack) env = - runExceptT (runReaderT stack env) - -{-# 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 -> - mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) - Nothing -> - fmap (Left . ClientError) (LibPQ.errorMessage connection) - --- | --- Fetch a single result. -{-# INLINE getResult #-} -getResult :: Results LibPQ.Result -getResult = - Results - $ ReaderT - $ \(_, connection) -> ExceptT $ do - resultMaybe <- LibPQ.getResult connection - case resultMaybe of - Just result -> pure (Right result) - Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) - --- | --- Fetch a single result. -{-# INLINE getResultMaybe #-} -getResultMaybe :: Results (Maybe LibPQ.Result) -getResultMaybe = - Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection - -{-# INLINE dropRemainders #-} -dropRemainders :: Results () -dropRemainders = - {-# SCC "dropRemainders" #-} - Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection - where - loop integerDatetimes connection = - getResultMaybe >>= Prelude.maybe (pure ()) onResult - where - getResultMaybe = - lift $ LibPQ.getResult connection - onResult result = - loop integerDatetimes connection <* checkErrors - where - checkErrors = - ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result) - -refine :: (a -> Either Text b) -> Results a -> Results b -refine refiner results = Results - $ ReaderT - $ \env -> ExceptT $ do - resultEither <- run results env - return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner diff --git a/library/Hasql/Private/Decoders/Row.hs b/library/Hasql/Private/Decoders/Row.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders/Row.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Hasql.Private.Decoders.Row where - -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Private.Decoders.Value as Value -import Hasql.Private.Errors -import Hasql.Private.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 - $ mapLeft 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/library/Hasql/Private/Decoders/Value.hs b/library/Hasql/Private/Decoders/Value.hs deleted file mode 100644 --- a/library/Hasql/Private/Decoders/Value.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Hasql.Private.Decoders.Value where - -import Hasql.Private.Prelude -import qualified PostgreSQL.Binary.Decoding as A - -newtype Value a - = Value (Bool -> A.Value a) - deriving (Functor) - -{-# INLINE run #-} -run :: Value a -> Bool -> A.Value a -run (Value imp) integerDatetimes = - imp integerDatetimes - -{-# 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 diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs deleted file mode 100644 --- a/library/Hasql/Private/Encoders.hs +++ /dev/null @@ -1,423 +0,0 @@ --- | --- A DSL for declaration of query parameter encoders. -module Hasql.Private.Encoders where - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Hasql.Private.Encoders.Array as Array -import qualified Hasql.Private.Encoders.Params as Params -import qualified Hasql.Private.Encoders.Value as Value -import qualified Hasql.Private.PTI as PTI -import Hasql.Private.Prelude hiding (bool) -import qualified Hasql.Private.Prelude as Prelude -import qualified Network.IP.Addr as NetworkIp -import qualified PostgreSQL.Binary.Encoding as A -import qualified Text.Builder 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, Decidable, 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 (NetworkIp.NetAddr NetworkIp.IP) -inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet)) - --- | --- 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)) - --- | --- 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.Builder]) - -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 arrayOID encode print)) -> - Composite - (\val idt -> A.field (PTI.oidWord32 elementOID) (encode idt val)) - (\val -> [print val]) - Nullable (Value (Value.Value elementOID arrayOID encode print)) -> - Composite - ( \val idt -> case val of - Nothing -> A.nullField (PTI.oidWord32 elementOID) - Just val -> A.field (PTI.oidWord32 elementOID) (encode idt val) - ) - ( \val -> - case val of - Nothing -> ["NULL"] - Just val -> [print val] - ) diff --git a/library/Hasql/Private/Encoders/Array.hs b/library/Hasql/Private/Encoders/Array.hs deleted file mode 100644 --- a/library/Hasql/Private/Encoders/Array.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Hasql.Private.Encoders.Array where - -import qualified Hasql.Private.PTI as B -import Hasql.Private.Prelude -import qualified PostgreSQL.Binary.Encoding as A -import qualified Text.Builder as C - -data Array a - = Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.Builder) - -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.Builder) -> 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.Builder) -> 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.null builder - then C.char '[' <> elRenderer el - else builder <> C.string ", " <> elRenderer el - in fold step mempty els - in if C.null folded - then C.string "[]" - else folded <> C.char ']' - in Array valueOID arrayOID encoder renderer diff --git a/library/Hasql/Private/Encoders/Params.hs b/library/Hasql/Private/Encoders/Params.hs deleted file mode 100644 --- a/library/Hasql/Private/Encoders/Params.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Hasql.Private.Encoders.Params where - -import qualified Database.PostgreSQL.LibPQ as A -import qualified Hasql.Private.Encoders.Value as C -import qualified Hasql.Private.PTI as D -import Hasql.Private.Prelude -import qualified PostgreSQL.Binary.Encoding as B -import qualified Text.Builder as E - --- | --- Encoder of some representation of a parameters product. -newtype Params a - = Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a) - deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) - -value :: C.Value a -> Params a -value = - contramap Just . nullableValue - -nullableValue :: C.Value a -> Params (Maybe a) -nullableValue (C.Value valueOID arrayOID encode render) = - Params - $ Op - $ \input -> - let D.OID _ pqOid format = - valueOID - encoder env = - fmap (B.encodingBytes . encode env) input - rendering = - maybe "null" (E.run . render) input - in pure (pqOid, format, encoder, rendering) diff --git a/library/Hasql/Private/Encoders/Value.hs b/library/Hasql/Private/Encoders/Value.hs deleted file mode 100644 --- a/library/Hasql/Private/Encoders/Value.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Hasql.Private.Encoders.Value where - -import qualified Hasql.Private.PTI as PTI -import Hasql.Private.Prelude -import qualified PostgreSQL.Binary.Encoding as B -import qualified Text.Builder as C - -data Value a - = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder) - -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.Builder) -> 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/library/Hasql/Private/Errors.hs b/library/Hasql/Private/Errors.hs deleted file mode 100644 --- a/library/Hasql/Private/Errors.hs +++ /dev/null @@ -1,147 +0,0 @@ --- | --- 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.Private.Errors where - -import qualified Data.ByteString.Char8 as BC -import Hasql.Private.Prelude - --- | --- An error during the execution of a query. --- Comes packed with the query template and a textual representation of the provided params. -data QueryError - = QueryError ByteString [Text] CommandError - deriving (Show, Eq, Typeable) - -instance Exception QueryError where - displayException (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: " - <> case commandError of - ClientError (Just message) -> "Client error: " <> show message - ClientError Nothing -> "Unknown client error" - ResultError resultError -> case resultError of - ServerError code message details hint position -> - "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 -> - "Row error: " <> show row <> ":" <> 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/library/Hasql/Private/IO.hs b/library/Hasql/Private/IO.hs deleted file mode 100644 --- a/library/Hasql/Private/IO.hs +++ /dev/null @@ -1,162 +0,0 @@ --- | --- An API of low-level IO operations. -module Hasql.Private.IO where - -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Private.Commands as Commands -import qualified Hasql.Private.Decoders.Result as ResultDecoders -import qualified Hasql.Private.Decoders.Results as ResultsDecoders -import qualified Hasql.Private.Encoders.Params as ParamsEncoders -import Hasql.Private.Errors -import Hasql.Private.Prelude -import qualified Hasql.Private.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 connection = - LibPQ.finish connection - -{-# INLINE checkConnectionStatus #-} -checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString)) -checkConnectionStatus c = - do - s <- LibPQ.status c - case s of - LibPQ.ConnectionOk -> return Nothing - _ -> fmap Just (LibPQ.errorMessage c) - -{-# INLINE checkServerVersion #-} -checkServerVersion :: LibPQ.Connection -> IO (Maybe Int) -checkServerVersion c = - fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c) - -{-# INLINE getIntegerDatetimes #-} -getIntegerDatetimes :: LibPQ.Connection -> IO Bool -getIntegerDatetimes c = - fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes" - where - decodeValue = - \case - Just "on" -> True - _ -> False - -{-# INLINE initConnection #-} -initConnection :: LibPQ.Connection -> IO () -initConnection c = - void $ LibPQ.exec c (Commands.asBytes (Commands.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 (integerDatetimes, connection) - dropRemainders = - ResultsDecoders.run ResultsDecoders.dropRemainders (integerDatetimes, connection) - -{-# 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 wordOIDList - where - wordOIDList = - map (\(LibPQ.Oid x) -> fromIntegral x) oidList - onNewRemoteKey key = - do - sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) - let resultsDecoder = - if sent - then ResultsDecoders.single ResultDecoders.noResult - else ResultsDecoders.clientError - fmap resultsMapping $ getResults connection undefined resultsDecoder - where - 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 -> fmap (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 (ParamsEncoders.Params (Op encoderOp)) input = - let (oidList, valueAndFormatList) = - let step (oid, format, encoder, _) ~(oidList, bytesAndFormatList) = - (,) - (oid : oidList) - (fmap (\bytes -> (bytes, format)) (encoder integerDatetimes) : bytesAndFormatList) - in foldr step ([], []) (encoderOp input) - in runExceptT $ do - key <- ExceptT $ getPreparedStatementKey connection registry template oidList - ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary - -{-# INLINE sendUnpreparedParametricStatement #-} -sendUnpreparedParametricStatement :: - LibPQ.Connection -> - Bool -> - ByteString -> - ParamsEncoders.Params a -> - a -> - IO (Either CommandError ()) -sendUnpreparedParametricStatement connection integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input = - let params = - let step (oid, format, encoder, _) acc = - ((,,) <$> pure oid <*> encoder integerDatetimes <*> pure format) : acc - in foldr step [] (encoderOp input) - in checkedSend connection $ LibPQ.sendQueryParams connection template params 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/library/Hasql/Private/PTI.hs b/library/Hasql/Private/PTI.hs deleted file mode 100644 --- a/library/Hasql/Private/PTI.hs +++ /dev/null @@ -1,230 +0,0 @@ -module Hasql.Private.PTI where - -import qualified Database.PostgreSQL.LibPQ as LibPQ -import Hasql.Private.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) - -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) - -int8 :: PTI -int8 = mkPTI LibPQ.Binary 20 (Just 1016) - -int8range :: PTI -int8range = mkPTI LibPQ.Binary 3926 (Just 3927) - -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) - -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) - -tstzrange :: PTI -tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911) - -tsvector :: PTI -tsvector = mkPTI LibPQ.Binary 3614 (Just 3643) - -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/library/Hasql/Private/Prelude.hs b/library/Hasql/Private/Prelude.hs deleted file mode 100644 --- a/library/Hasql/Private/Prelude.hs +++ /dev/null @@ -1,137 +0,0 @@ -module Hasql.Private.Prelude - ( module Exports, - LazyByteString, - ByteStringBuilder, - LazyText, - TextBuilder, - forMToZero_, - forMFromZero_, - strictCons, - mapLeft, - ) -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, 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.DList as Exports (DList) -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.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.IORef as Exports -import Data.Int 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.Profunctor.Unsafe as Exports -import Data.Proxy as Exports -import Data.Ratio as Exports -import Data.STRef as Exports -import Data.Scientific as Exports (Scientific) -import Data.Semigroup as Exports hiding (First (..), Last (..)) -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.UUID as Exports (UUID) -import Data.Unique as Exports -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 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 Prelude as Exports hiding (Read, all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) - -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 -> if n >= 0 then f n *> loop (pred n) else pure () - -{-# INLINE forMFromZero_ #-} -forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m () -forMFromZero_ !endN f = - ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure () - -{-# INLINE strictCons #-} -strictCons :: a -> [a] -> [a] -strictCons !a b = - let !c = a : b in c - -{-# INLINE mapLeft #-} -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft f = - either (Left . f) Right diff --git a/library/Hasql/Private/PreparedStatementRegistry.hs b/library/Hasql/Private/PreparedStatementRegistry.hs deleted file mode 100644 --- a/library/Hasql/Private/PreparedStatementRegistry.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Hasql.Private.PreparedStatementRegistry - ( PreparedStatementRegistry, - new, - update, - LocalKey (..), - ) -where - -import qualified ByteString.StrictBuilder as B -import qualified Data.HashTable.IO as A -import Hasql.Private.Prelude hiding (lookup) - -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 - --- | --- Local statement key. -data LocalKey - = LocalKey !ByteString ![Word32] - deriving (Show, Eq) - -instance Hashable LocalKey where - {-# INLINE hashWithSalt #-} - hashWithSalt salt (LocalKey template types) = - hashWithSalt salt template diff --git a/library/Hasql/Private/Session.hs b/library/Hasql/Private/Session.hs deleted file mode 100644 --- a/library/Hasql/Private/Session.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Hasql.Private.Session where - -import qualified Hasql.Private.Connection as Connection -import qualified Hasql.Private.Decoders.Result as Decoders.Result -import qualified Hasql.Private.Decoders.Results as Decoders.Results -import qualified Hasql.Private.Encoders as Encoders -import qualified Hasql.Private.Encoders.Params as Encoders.Params -import Hasql.Private.Errors -import qualified Hasql.Private.IO as IO -import Hasql.Private.Prelude -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 QueryError IO) a) - deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection) - --- | --- Executes a bunch of commands on the provided connection. -run :: Session a -> Connection.Connection -> IO (Either QueryError a) -run (Session impl) connection = - runExceptT - $ runReaderT impl connection - --- | --- 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 registry) -> - ExceptT - $ fmap (mapLeft (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 - --- | --- Parameters and a specification of a parametric single-statement query to apply them to. -statement :: params -> Statement.Statement params result -> Session result -statement input (Statement.Statement template (Encoders.Params paramsEncoder) decoder preparable) = - Session - $ ReaderT - $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> - ExceptT - $ fmap (mapLeft (QueryError template inputReps)) - $ withMVar pqConnectionRef - $ \pqConnection -> do - r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input - r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder) - return $ r1 *> r2 - where - inputReps = - let Encoders.Params.Params (Op encoderOp) = paramsEncoder - step (_, _, _, rendering) acc = - rendering : acc - in foldr step [] (encoderOp input) diff --git a/library/Hasql/Private/Settings.hs b/library/Hasql/Private/Settings.hs deleted file mode 100644 --- a/library/Hasql/Private/Settings.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Hasql.Private.Settings where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL -import Hasql.Private.Prelude - --- | --- All settings encoded in a single byte-string according to --- . -type Settings = - ByteString - --- | --- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string. -{-# INLINE settings #-} -settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings -settings host port user password database = - BL.toStrict - $ BB.toLazyByteString - $ mconcat - $ intersperse (BB.char7 ' ') - $ catMaybes - $ [ mappend (BB.string7 "host=") - . BB.byteString - <$> mfilter (not . B.null) (pure host), - mappend (BB.string7 "port=") - . BB.word16Dec - <$> mfilter (/= 0) (pure port), - mappend (BB.string7 "user=") - . BB.byteString - <$> mfilter (not . B.null) (pure user), - mappend (BB.string7 "password=") - . BB.byteString - <$> mfilter (not . B.null) (pure password), - mappend (BB.string7 "dbname=") - . BB.byteString - <$> mfilter (not . B.null) (pure database) - ] diff --git a/library/Hasql/Session.hs b/library/Hasql/Session.hs --- a/library/Hasql/Session.hs +++ b/library/Hasql/Session.hs @@ -7,9 +7,9 @@ run, -- * Errors - module Hasql.Private.Errors, + module Hasql.Errors, ) where -import Hasql.Private.Errors -import Hasql.Private.Session +import Hasql.Errors +import Hasql.Session.Core diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Session/Core.hs @@ -0,0 +1,65 @@ +module Hasql.Session.Core where + +import qualified Hasql.Connection.Core as Connection +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 Hasql.Prelude +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 QueryError IO) a) + deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection) + +-- | +-- Executes a bunch of commands on the provided connection. +run :: Session a -> Connection.Connection -> IO (Either QueryError a) +run (Session impl) connection = + runExceptT + $ runReaderT impl connection + +-- | +-- 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 registry) -> + ExceptT + $ fmap (mapLeft (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 + +-- | +-- Parameters and a specification of a parametric single-statement query to apply them to. +statement :: params -> Statement.Statement params result -> Session result +statement input (Statement.Statement template (Encoders.Params paramsEncoder) decoder preparable) = + Session + $ ReaderT + $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> + ExceptT + $ fmap (mapLeft (QueryError template inputReps)) + $ withMVar pqConnectionRef + $ \pqConnection -> do + r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input + r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder) + return $ r1 *> r2 + where + inputReps = + let Encoders.Params.Params (Op encoderOp) = paramsEncoder + step (_, _, _, rendering) acc = + rendering : acc + in foldr step [] (encoderOp input) diff --git a/library/Hasql/Settings.hs b/library/Hasql/Settings.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Settings.hs @@ -0,0 +1,39 @@ +module Hasql.Settings where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import Hasql.Prelude + +-- | +-- All settings encoded in a single byte-string according to +-- . +type Settings = + ByteString + +-- | +-- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string. +{-# INLINE settings #-} +settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings +settings host port user password database = + BL.toStrict + $ BB.toLazyByteString + $ mconcat + $ intersperse (BB.char7 ' ') + $ catMaybes + $ [ mappend (BB.string7 "host=") + . BB.byteString + <$> mfilter (not . B.null) (pure host), + mappend (BB.string7 "port=") + . BB.word16Dec + <$> mfilter (/= 0) (pure port), + mappend (BB.string7 "user=") + . BB.byteString + <$> mfilter (not . B.null) (pure user), + mappend (BB.string7 "password=") + . BB.byteString + <$> mfilter (not . B.null) (pure password), + mappend (BB.string7 "dbname=") + . BB.byteString + <$> mfilter (not . B.null) (pure database) + ] diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -13,9 +13,9 @@ where import qualified Hasql.Decoders as Decoders +import qualified Hasql.Decoders.All as Decoders import qualified Hasql.Encoders as Encoders -import qualified Hasql.Private.Decoders as Decoders -import Hasql.Private.Prelude +import Hasql.Prelude -- | -- Specification of a strictly single-statement query, which can be parameterized and prepared.