packages feed

psql (empty) → 0.0.0

raw patch · 17 files changed

+2534/−0 lines, 17 filesdep +basedep +bytestringdep +cgroup-rts-threads

Dependencies added: base, bytestring, cgroup-rts-threads, concurrency, containers, cryptonite, exceptions, hspec, massiv, megaparsec, mtl, postgresql-libpq, psql, semigroupoids, simpoole, sop-core, template-haskell, text, unordered-containers, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# psql++## 0.0.0++This is the root version.
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Ole Krüger++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++* Redistributions of source code must retain the above copyright+  notice, this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+* Neither the name of the author nor the+  names of its contributors may be used to endorse or promote products+  derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ lib/PostgreSQL.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | PostgreSQL client+--+-- Have a look at the individual sub-sections to find out more about the respective concepts.+--+module PostgreSQL+  ( -- * Templates and statements+    -- $templatesAndStatements++    -- ** Templates+    -- $templatesAndStatements_templates+    Statement.Template+  , Statement.renderTemplate++    -- *** Quasi-quotation+  , Statement.tpl++    -- *** Combinators+    -- $templatesAndStatements_templates_combinators+  , Statement.code+  , Statement.identifier+  , Statement.string+  , Statement.param+  , Statement.paramWith+  , Statement.constant++    -- ** Statements+    -- $templatesAndStatements_statements+  , Statement.Statement+  , Statement.stmt++    -- ** Prepared statements+    -- $templatesAndStatements_prepadeStatements+  , Statement.PreparedStatement++    -- * Query execution+    -- $queryExecution++    -- ** Combinators+  , Query.execute+  , Query.execute_+  , Query.query+  , Query.queryWith+  , Query.withPreparedStatement++    -- ** Evaluation+  , Query.Query+  , Class.RunQuery (..)+  , Class.runQueryThrow++    -- ** Interpreters+  , ConnectionPool.ConnectionPoolT+  , ConnectionPool.runConnectionPoolT+  , ConnectionPool.defaultConnectionPoolSettings++    -- * Result processing+    -- ** Top level+  , Result.Result+  , Result.ignored+  , Result.single+  , Result.first+  , Result.many+  , Result.affectedRows++    -- ** Row level+  , Row.Row+  , Row.column+  , Row.columnWith+  , Row.fixedColumn+  , Row.fixedColumnWith+  , Row.namedColumn+  , Row.namedColumnWith+  , Row.AutoRow (..)+  , Row.AutoColumnDelegate+  , Row.genericRow+  , Row.Named (..)+  , Row.Fixed (..)++    -- ** Column level+  , Column.Column+  , Column.AutoColumn (..)+  , Column.Readable (..)++    -- * Errors+  , Types.Error (..)+  , Types.Errors+  , Types.ProcessorError (..)+  , Types.ProcessorErrors+  , Types.ResultError (..)+  , Types.ResultErrors+  , Types.ParserError (..)+  , Types.ParserErrors++    -- * Common types+  , Types.Format (..)+  , Types.Oid+  , Types.ColumnNum+  , Types.RowNum+  , Types.Value (..)+  , Column.RawValue (..)+  )+where++import qualified PostgreSQL.Class as Class+import qualified PostgreSQL.ConnectionPool as ConnectionPool+import qualified PostgreSQL.Query as Query+import qualified PostgreSQL.Result as Result+import qualified PostgreSQL.Result.Column as Column+import qualified PostgreSQL.Result.Row as Row+import qualified PostgreSQL.Statement as Statement+import qualified PostgreSQL.Types as Types++-- $templatesAndStatements+--+-- Writing a statement usually involves writing it as a 'Statement.Template' and then rendering it+-- as a 'Statement.Statement'. The latter can optionally be prepared to become a+-- 'Statement.PreparedStatement'.+--+-- Templates and statements can take an input. The type of that input is determined by the type+-- parameter that 'Statement.Template', 'Statement.Statement' and 'Statement.PreparedStatement+-- expose.+--++-- $templatesAndStatements_templates+--+-- Templates can be constructed using the 'Statement.tpl' quasi-quoter or manually using the+-- provided combinators.+--++-- $templatesAndStatements_templates_combinators+--+-- 'Statement.Template' implements 'Semigroup' and 'Monoid'. These can be used to compose the+-- following combinators.+--+-- It also supports 'IsString' which helps to create templates from string literals.+--+-- You may use overloaded labels to refer to parameters.+--+-- prop> #my_param === param my_param+--+-- @my_param@ shall be a record field of data type.+--++-- $templatesAndStatements_statements+--+-- 'Statement.Statement's are created using the 'Statement.stmt' quasi-quoter or by rendering a+-- 'Statement.Template' via 'Statement.renderTemplate'.+--++-- $templatesAndStatements_prepadeStatements+--+-- 'Statement.PreparedStatement's can be obtained using 'Query.withPreparedStatement'.+--+-- This can be useful when executing a statement repeatedly and you want to save some time on+-- parsing and type-checking the statement on the database server.+--++-- $queryExecution+--+-- Queries are built using any type @query@ that satisfies @'Query.Query' query@. The combinators+-- below are used to run or prepare statements.+--+-- In most cases you will use 'Class.runQuery' or 'Class.runQueryThrow' to then actually run the+-- query.+--+-- 'ConnectionPool.ConnectionPoolT' is a useful interpreter for the 'Class.RunQuery' effect.+--
+ lib/PostgreSQL/Class.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | General class declarations+module PostgreSQL.Class+  ( RunQuery (..)+  , runQueryThrow+  )+where++import qualified Control.Monad.Catch as Catch+import           Control.Monad.Trans (MonadTrans (lift))+import qualified Data.List.NonEmpty as NonEmpty+import           PostgreSQL.Query.Class (Query)+import           PostgreSQL.Types (Errors)++-- | PostgreSQL queries can be executed in @m@+--+-- @since 0.0.0+class Query query => RunQuery query m | m -> query where+  -- | Run a query.+  --+  -- @since 0.0.0+  runQuery :: query a -> m (Either Errors a)++-- | Like 'runQuery' but throws the first error instead.+--+-- @since 0.0.0+runQueryThrow :: (Catch.MonadThrow m, RunQuery query m) => query a -> m a+runQueryThrow query = do+  err <- runQuery query+  either (Catch.throwM . NonEmpty.head) pure err++{-# INLINE runQueryThrow #-}++-- | @since 0.0.0+instance+  {-# OVERLAPPABLE #-}+  (RunQuery query m, Monad m, MonadTrans t)+  => RunQuery query (t m)+  where+    runQuery query = lift (runQuery query)++    {-# INLINE runQuery #-}
+ lib/PostgreSQL/ConnectionPool.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module defines an interpreter for 'Class.RunQuery'.+module PostgreSQL.ConnectionPool+  ( ConnectionPoolT (..)+  , runConnectionPoolT+  , defaultConnectionPoolSettings+  , connectionPoolMetrics+  )+where++import qualified Control.Monad.Catch as Catch+import           Control.Monad.Conc.Class (MonadConc)+import qualified Control.Monad.Except as Except+import           Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Control.Monad.Reader as Reader+import           Control.Monad.State.Class (MonadState)+import           Control.Monad.Trans (MonadTrans, lift)+import           Control.Monad.Writer.Class (MonadWriter)+import qualified Database.PostgreSQL.LibPQ as PQ+import           Numeric.Natural (Natural)+import qualified PostgreSQL.Class as Class+import qualified PostgreSQL.Query as Query+import           PostgreSQL.Types (Connection)+import qualified Simpoole as Pool+import qualified Simpoole.Monad as Pool.Monad+import qualified Simpoole.Monad.Internal as Pool.Monad++-- | Interpreter for 'Class.RunQuery' which dispatches queries to a pool of database connections+--+-- @since 0.0.0+newtype ConnectionPoolT m a = ConnectionPoolT+  { unConnectionPoolT :: Pool.Monad.PoolT Connection m a }+  deriving newtype+    ( Functor -- ^ @since 0.0.0+    , Applicative -- ^ @since 0.0.0+    , Monad -- ^ @since 0.0.0+    , MonadFail -- ^ @since 0.0.0+    , MonadIO -- ^ @since 0.0.0+    , MonadState s -- ^ @since 0.0.0+    , Except.MonadError e -- ^ @since 0.0.0+    , MonadWriter w -- ^ @since 0.0.0+    , Catch.MonadThrow -- ^ @since 0.0.0+    , Catch.MonadCatch -- ^ @since 0.0.0+    , Catch.MonadMask -- ^ @since 0.0.0+    , MonadConc -- ^ @since 0.0.0+    )++-- | @since 0.0.0+instance MonadTrans ConnectionPoolT where+  lift = ConnectionPoolT . Reader.lift++-- | @since 0.0.0+instance+  (Catch.MonadMask m, MonadIO m)+  => Class.RunQuery (Query.QueryT m) (ConnectionPoolT m)+  where+    runQuery query = ConnectionPoolT $ Pool.Monad.withResource $ \conn ->+      lift $ Query.runQueryT conn query++    {-# INLINE runQuery #-}++-- | Default settings for the connection pool+--+-- @since 0.0.0+defaultConnectionPoolSettings :: Pool.Settings+defaultConnectionPoolSettings = Pool.defaultSettings+  { Pool.settings_idleTimeout = Just 60 -- seconds+  , Pool.settings_returnPolicy = Pool.ReturnToFront+  , Pool.settings_maxLiveLimit = Nothing+  }++-- | Run connection pool transformer.+--+-- @since 0.0.0+runConnectionPoolT+  :: (MonadIO m, MonadConc m)+  => m Connection+  -- ^ Action to establish a new connection+  -> Pool.Settings+  -- ^ Connection pool settings+  -> ConnectionPoolT m a+  -- ^ Transformer to run+  -> m a+runConnectionPoolT connect poolSettings (ConnectionPoolT inner) = do+  pool <- Pool.newPool connect (liftIO . PQ.finish) poolSettings+  Pool.Monad.runPoolT pool inner++{-# INLINE runConnectionPoolT #-}++-- | Retrieve the connection pool metrics.+--+-- @since 0.0.0+connectionPoolMetrics :: ConnectionPoolT m (Pool.Metrics Natural)+connectionPoolMetrics = ConnectionPoolT Pool.Monad.metricsPoolT
+ lib/PostgreSQL/Param.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Here are things dealing with query parameters.+module PostgreSQL.Param+  ( -- * Basics+    Type (..)+  , typeOid+  , Info (..)++  , Types.Value (..)+  , Types.Oid+  , Types.Format (..)++  , Types.PackedParam (..)+  , packParam+  , toPrepared++  , Types.PackedParamPrepared (..)+  , packParamPrepared++    -- * Class+  , Param (..)+  , RawText (..)+  )+where++import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as ByteString.Char8+import           Data.Text (Text)+import           Data.Text.Encoding (encodeUtf8)+import           Database.PostgreSQL.LibPQ (invalidOid)+import           GHC.Generics (Generic)+import qualified PostgreSQL.Types as Types++-- | Parameter type+--+-- @since 0.0.0+data Type+  = InferredType+  -- ^ Type is inferred on the server side+  --+  -- @since 0.0.0+  | StaticType Types.Oid+  -- ^ Explicit static type+  --+  -- @since 0.0.0+  deriving (Show, Eq, Ord)++-- | Get the OID for the type.+--+-- @since 0.0.0+typeOid :: Type -> Types.Oid+typeOid = \case+  InferredType -> invalidOid+  StaticType oid -> oid++{-# INLINE typeOid #-}++-- | Static parameter information+--+-- @since 0.0.0+data Info a = Info+  { info_type :: Type+  , info_typeName :: Maybe Text+  -- ^ This may be used as an explicit type annotation when used in a 'Statement' or 'Template'+  , info_format :: Types.Format+  , info_pack :: a+  }+  deriving stock (Functor, Foldable, Traversable, Generic)++-- | Pack a parameter into a @postgresql-libpq@ format.+--+-- @since 0.0.0+packParam :: Info Types.Value -> Types.PackedParam+packParam paramInfo = Types.PackedParam $+  case info_pack paramInfo of+    Types.Null -> Nothing+    Types.Value datas -> Just (oid, datas, info_format paramInfo)+  where+    oid = typeOid $ info_type paramInfo++{-# INLINE packParam #-}++-- | Convert 'PackedParam'.+--+-- @since 0.0.0+toPrepared :: Types.PackedParam -> Types.PackedParamPrepared+toPrepared (Types.PackedParam param) = Types.PackedParamPrepared $ do+  (_, datas, format) <- param+  pure (datas, format)++{-# INLINE toPrepared #-}++-- | Pack a parameter for a prepared query into a @postgresql-libpq@ format.+--+-- @since 0.0.0+packParamPrepared :: Info Types.Value -> Types.PackedParamPrepared+packParamPrepared paramInfo = Types.PackedParamPrepared $+  case info_pack paramInfo of+    Types.Null -> Nothing+    Types.Value datas -> Just (datas, info_format paramInfo)++{-# INLINE packParamPrepared #-}++-- | @a@ can be used as a parameter+--+-- @since 0.0.0+class Param a where+  -- | Parameter information+  --+  -- @since 0.0.0+  paramInfo :: Info (a -> Types.Value)++-- | @since 0.0.0+instance Param Integer where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Nothing+    , info_format = Types.Text+    , info_pack = Types.Value . ByteString.Char8.pack . show+    }++-- | @since 0.0.0+instance Param Double where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Just "float8"+    , info_format = Types.Text+    , info_pack = Types.Value . ByteString.Char8.pack . show+    }++-- | @since 0.0.0+instance Param Text where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Nothing+    , info_format = Types.Text+    , info_pack = Types.Value . encodeUtf8+    }++-- | @since 0.0.0+instance Param Types.Oid where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Just "oid"+    , info_format = Types.Text+    , info_pack = \(Types.Oid inner) -> Types.Value $ ByteString.Char8.pack $ show inner+    }++-- | @since 0.0.0+instance Param Types.RegType where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Just "regtype"+    , info_format = Types.Text+    , info_pack = Types.Value . encodeUtf8 . Types.unRegType+    }++-- | Raw textual parameter+--+-- @since 0.0.0+newtype RawText = RawText+  { unRawText :: ByteString }+  deriving (Show, Eq, Ord)++-- | @since 0.0.0+instance Param RawText where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Nothing+    , info_format = Types.Text+    , info_pack = Types.Value . unRawText+    }++-- | @since 0.0.0+instance Param Types.Value where+  paramInfo = Info+    { info_type = InferredType+    , info_typeName = Nothing+    , info_format = Types.Text+    , info_pack = id+    }
+ lib/PostgreSQL/Query.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | In here one will find the things to execute database queries.+module PostgreSQL.Query+  ( -- * Query execution+    Class.execute+  , execute_+  , query+  , queryWith++    -- * Class+  , Class.Query (..)++    -- * Interpreter+  , QueryT+  , runQueryT+  , runQueryTThrow+  )+where++import           Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow (throwM), bracket)+import qualified Control.Monad.Except as Except+import           Control.Monad.IO.Class (MonadIO (liftIO))+import qualified Control.Monad.Reader as Reader+import           Control.Monad.State.Class (MonadState)+import           Control.Monad.Trans (MonadTrans (lift))+import           Control.Monad.Writer.Class (MonadWriter)+import           Data.Coerce (coerce)+import           Data.Functor (void)+import           Data.Functor.Alt (Alt (..))+import           Data.Functor.Apply (Apply)+import           Data.Functor.Bind (Bind (..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Text.Encoding (decodeUtf8)+import qualified Data.Vector as Vector+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified PostgreSQL.Param as Param+import qualified PostgreSQL.Query.Class as Class+import qualified PostgreSQL.Result as Result+import qualified PostgreSQL.Result.Row as Row+import qualified PostgreSQL.Statement as Statement+import           PostgreSQL.Types (Connection, Error (..), Errors, Format (Text))++---++-- | Like 'Class.execute' but does not concern itself with the result handle.+--+-- @since 0.0.0+execute_+  :: (Class.Executable statement, Class.Query query)+  => statement param+  -- ^ Statement+  -> param+  -- ^ Statement input+  -> query ()+execute_ statement param =+  void (Class.execute statement param)++{-# INLINE execute_ #-}++-- | Perform a parameterized query.+--+-- @since 0.0.0+query+  :: (Class.Executable statement, Class.Query query, Row.AutoRow row)+  => statement param+  -- ^ Query statement+  -> param+  -- ^ Query parameter+  -> query (Vector.Vector row)+query statement input =+  queryWith statement input (Result.many Row.autoRow)++{-# INLINE query #-}++-- | Perform a parameterized query. This also lets you specify the result processor explicitly.+--+-- @since 0.0.0+queryWith+  :: (Class.Executable statement, Class.Query query)+  => statement param+  -- ^ Query statement+  -> param+  -- ^ Query parameter+  -> Result.Result row+  -- ^ Result row processor+  -> query row+queryWith statement input resultProcessor = do+  result <- Class.execute statement input+  Class.processResult result resultProcessor++{-# INLINE queryWith #-}++---++-- | Interpreter for 'Class.Query'+--+-- @since 0.0.0+newtype QueryT m a = QueryT+  { unQueryT :: Reader.ReaderT Connection (Except.ExceptT Errors m) a }+  deriving newtype+    ( Functor -- ^ @since 0.0.0+    , Apply -- ^ @since 0.0.0+    , Applicative -- ^ @since 0.0.0+    , Monad -- ^ @since 0.0.0+    , MonadIO -- ^ @since 0.0.0+    , MonadState s -- ^ @since 0.0.0+    , MonadWriter s -- ^ @since 0.0.0+    , Except.MonadError Errors -- ^ @since 0.0.0+    , MonadThrow -- ^ @since 0.0.0+    , MonadCatch -- ^ @since 0.0.0+    , MonadMask -- ^ @since 0.0.0+    )++-- | @since 0.0.0+instance Monad m => Alt (QueryT m) where+  QueryT lhs <!> QueryT rhs = QueryT $ lhs <!> rhs++  {-# INLINE (<!>) #-}++-- | @since 0.0.0+instance Monad m => Bind (QueryT m) where+  QueryT x >>- f = QueryT (x >>- unQueryT . f)++  {-# INLINE (>>-) #-}++-- | @since 0.0.0+instance MonadTrans QueryT where+  lift = QueryT . lift . lift++  {-# INLINE lift #-}++-- | @since 0.0.0+instance Reader.MonadReader r m => Reader.MonadReader r (QueryT m) where+  ask = QueryT $ lift $ lift Reader.ask++  {-# INLINE ask #-}++  local f (QueryT inner) = QueryT $+    Reader.mapReaderT (Except.mapExceptT (Reader.local f)) inner++  {-# INLINE local #-}++prepareStatement+  :: MonadIO m+  => Statement.Statement a+  -> QueryT m (Statement.PreparedStatement a)+prepareStatement statement = QueryT $ Reader.ReaderT $ \conn -> do+  let name = Statement.statement_name statement++  mbResult <- liftIO $+    PQ.prepare+      conn+      name+      (Statement.statement_code statement)+      (Just (Statement.statement_types statement))++  _result <- Except.withExceptT (fmap ErrorDuringValidation) $+    Result.checkForError conn mbResult++  pure Statement.PreparedStatement+    { Statement.preparedStatement_name = name+    , Statement.preparedStatement_mkParams =+      map Param.toPrepared . Statement.statement_mkParams statement+    }++{-# INLINE prepareStatement #-}++deallocatePreparedStatement+  :: (MonadIO m, MonadMask m)+  => Statement.PreparedStatement a+  -> QueryT m ()+deallocatePreparedStatement statement =+  execute_ [Statement.stmt| DEALLOCATE $(quotedName) |] ()+  where+    quotedName = Statement.identifier $ decodeUtf8 $ Statement.preparedStatement_name statement++instance (MonadIO m, MonadMask m) => Class.Query (QueryT m) where+  type NativeResult (QueryT m) = PQ.Result++  executeStatement statement input = QueryT $ Reader.ReaderT $ \conn -> do+    mbResult <- liftIO $ do+      let code = Statement.statement_code statement+      case Statement.statement_mkParams statement input of+        []     -> PQ.exec conn code+        params -> PQ.execParams conn code (coerce params) Text++    Except.withExceptT (fmap ErrorDuringValidation) $ Result.checkForError conn mbResult++  {-# INLINE executeStatement #-}++  withPreparedStatement statement =+    bracket (prepareStatement statement) deallocatePreparedStatement++  {-# INLINE withPreparedStatement #-}++  executePreparedStatement statement input = QueryT $ Reader.ReaderT $ \conn -> do+    mbResult <- liftIO $+      PQ.execPrepared+        conn+        (Statement.preparedStatement_name statement)+        (coerce (Statement.preparedStatement_mkParams statement input))+        Text++    Except.withExceptT (fmap ErrorDuringValidation) $ Result.checkForError conn mbResult++  {-# INLINE executePreparedStatement #-}++  processResult result processor = QueryT+    $ Reader.lift+    $ Except.ExceptT+    $ Result.runResultPq result processor++  {-# INLINE processResult #-}++-- | Run an interaction with a PostgreSQL database.+--+-- @since 0.0.0+runQueryT+  :: Connection+  -> QueryT m a+  -> m (Either Errors a)+runQueryT conn (QueryT action) =+  Except.runExceptT $ Reader.runReaderT action conn++{-# INLINE runQueryT #-}++-- | Like 'runQueryT' but throw the first 'Error' instead.+--+-- @since 0.0.0+runQueryTThrow+  :: MonadThrow m+  => Connection+  -> QueryT m a+  -> m a+runQueryTThrow conn query = do+  result <- runQueryT conn query+  either (throwM . NonEmpty.head) pure result++{-# INLINE runQueryTThrow #-}
+ lib/PostgreSQL/Query/Class.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- | Class declarations for query execution+module PostgreSQL.Query.Class+  ( Query (..)+  , Executable (..)+  )+where++import           Data.Kind (Type)+import qualified PostgreSQL.Result as Result+import qualified PostgreSQL.Statement as Statement++-- | PostgreSQL query+--+-- @since 0.0.0+class Monad query => Query query where+  -- | Native query result+  --+  -- @since 0.0.0+  type NativeResult query :: Type++  -- | Execute a statement.+  --+  -- @since 0.0.0+  executeStatement+    :: Statement.Statement a+    -- ^ Statement+    -> a+    -- ^ Statement input+    -> query (NativeResult query)++  -- | Execute a previously prepared statement.+  --+  -- @since 0.0.0+  executePreparedStatement+    :: Statement.PreparedStatement a+    -- ^ Prepared statement+    -> a+    -- ^ Statement input+    -> query (NativeResult query)++  -- | Prepare a statement. The prepared statement is only valid within the provided continuation.+  --+  -- @since 0.0.0+  withPreparedStatement+    :: Statement.Statement a+    -- ^ Statement to prepare+    -> (Statement.PreparedStatement a -> query r)+    -- ^ Scope within the prepared statement may be used+    -> query r++  -- | Process the result object.+  --+  -- @since 0.0.0+  processResult+    :: NativeResult query+    -- ^ Result+    -> Result.Result a+    -- ^ Result processor+    -> query a++-- | @statement@ is an executable statement.+--+-- @since 0.0.0+class Executable statement where+  -- | Execute a statement.+  --+  -- @since 0.0.0+  execute+    :: Query query+    => statement param+    -- ^ Statement+    -> param+    -- ^ Statement input+    -> query (NativeResult query)++-- | @since 0.0.0+instance Executable Statement.Statement where+  execute = executeStatement++  {-# INLINE execute #-}++-- | @since 0.0.0+instance Executable Statement.PreparedStatement where+  execute = executePreparedStatement++  {-# INLINE execute #-}
+ lib/PostgreSQL/Result.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RankNTypes #-}++-- | This module is dedicated to dealing with query results.+module PostgreSQL.Result+  ( Result+  , runResultPq++    -- * Combinators+  , ignored+  , single+  , first+  , many+  , affectedRows++    -- * Validation+  , checkForError+  )+where++import           Control.Monad (when)+import qualified Control.Monad.Except as Except+import           Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Bifunctor as Bifunctor+import qualified Data.ByteString as ByteString+import           Data.Foldable (for_)+import           Data.Maybe (fromMaybe)+import qualified Data.Text as Text+import           Data.Text.Encoding (decodeUtf8')+import qualified Data.Vector as Vector+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified PostgreSQL.Result.Row as Row+import qualified PostgreSQL.Types as Types+import           Text.Read (readEither)++data ResultF a where+  IgnoreResult :: ResultF ()++  SingleRow :: Row.Row a -> ResultF a++  FirstRow :: Row.Row a -> ResultF a++  ManyRows :: Row.Row a -> ResultF (Vector.Vector a)++  AffectedRows :: ResultF Integer++-- | Query result+--+-- @since 0.0.0+data Result a where+  Result :: (b -> a) -> ResultF b -> Result a++-- | @since 0.0.0+instance Functor Result where+  fmap f (Result g inner) = Result (f . g) inner++  {-# INLINE fmap #-}++-- | Process libpq's 'PQ.Result'.+--+-- @since 0.0.0+runResultPq :: MonadIO m => PQ.Result -> Result a -> m (Either Types.Errors a)+runResultPq result (Result f basis) = Except.runExceptT $ fmap f $+  case basis of+    IgnoreResult ->+      pure ()++    SingleRow row -> do+      rows <- liftIO (PQ.ntuples result)+      when (rows /= 1) $+        Except.throwError [Types.ErrorDuringValidation $ Types.MultipleRows $ Types.RowNum rows]+      runRow <- importErrors (Row.runRowPq result row)+      importErrors (runRow 0)++    FirstRow row -> do+      rows <- liftIO (PQ.ntuples result)+      when (rows < 1) $ Except.throwError [Types.ErrorDuringValidation Types.NoRows]+      runRow <- importErrors (Row.runRowPq result row)+      importErrors (runRow 0)++    ManyRows row -> do+      runRow <- importErrors (Row.runRowPq result row)+      PQ.Row rows <- liftIO (PQ.ntuples result)+      Vector.generateM (fromIntegral rows) (importErrors . runRow . fromIntegral)++    AffectedRows -> do+      tuples <- liftIO (PQ.cmdTuples result)+      case tuples of+        Nothing -> pure 0+        Just tuples ->+          Except.liftEither+          $ Bifunctor.first+            (pure . Types.ErrorDuringValidation . Types.FailedToParseAffectedRows . Text.pack)+          $ do+            tuples <- Bifunctor.first show (decodeUtf8' tuples)+            readEither (Text.unpack tuples)+  where+    importErrors = Except.withExceptT (fmap Types.ErrorDuringProcessing)+++-- | Ignore the result set.+--+-- @since 0.0.0+ignored :: Result ()+ignored = Result id IgnoreResult++-- | Process exactly 1 row.+--+-- @since 0.0.0+single :: Row.Row a -> Result a+single row = Result id (SingleRow row)++-- | Process only the first row. There may be more rows in the result set, but they won't be+-- touched.+--+-- @since 0.0.0+first :: Row.Row a -> Result a+first row = Result id (FirstRow row)++-- | Process 0 or more rows.+--+-- @since 0.0.0+many :: Row.Row a -> Result (Vector.Vector a)+many row = Result id (ManyRows row)+++-- | Get the number of affected rows.+--+-- @since 0.0.0+affectedRows :: Result Integer+affectedRows = Result id AffectedRows++---++-- | Check the result, if any, and the connection for errors.+--+-- @since 0.0.0+checkForError+  :: (MonadIO m, Except.MonadError Types.ResultErrors m)+  => Types.Connection+  -> Maybe PQ.Result+  -> m PQ.Result+checkForError conn mbResult = do+  result <-+    case mbResult of+      Nothing -> do+        connError <- liftIO $ PQ.errorMessage conn+        Except.throwError [Types.BadResultStatus (fromMaybe mempty connError)]++      Just result -> pure result++  resultError <- liftIO $ PQ.resultErrorMessage result+  for_ resultError $ \error ->+    when (ByteString.length error > 0) $+      Except.throwError [Types.BadResultStatus error]++  pure result++{-# INLINE checkForError #-}
+ lib/PostgreSQL/Result/Cell.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++-- The derived Alt instance for Cell causes this.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Things in this module are dedicated to parsing Postgres values independent of their format or+-- type.+module PostgreSQL.Result.Cell+  ( Cell (..)+  , ignored+  , raw+  , text+  , readable+  , validate+  )+where++import           Control.Monad ((>=>))+import           Control.Monad.Except (Except, ExceptT (..))+import           Control.Monad.Reader (ReaderT (..))+import           Data.Bifunctor (first)+import           Data.ByteString (ByteString)+import           Data.Functor.Alt (Alt (..))+import           Data.Functor.Identity (Identity (..))+import           Data.List.NonEmpty (NonEmpty)+import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.Text.Encoding (decodeUtf8')+import           PostgreSQL.Types (Value (..))+import           Text.Read (readEither)++-- | Cell value parser+--+-- @since 0.0.0+newtype Cell a = Cell+  { parseCell :: Value -> Either (NonEmpty Text) a }+  deriving stock Functor -- ^ @since 0.0.0++-- | @since 0.0.0+deriving via ReaderT Value (Except (NonEmpty Text)) instance Alt Cell++-- | Do not parse the cell at all.+--+-- @since 0.0.0+ignored :: Cell ()+ignored = Cell $ \_ -> Right ()++{-# INLINE ignored #-}++-- | Get the raw cell value. Does not allow @NULL@.+--+-- @since 0.0.0+raw :: Cell ByteString+raw = Cell $ \case+  Null -> Left ["Can't be NULL"]+  Value encoded -> Right encoded++{-# INLINE raw #-}++-- | Parse as UTF-8 'Text'. Does not allow @NULL@.+--+-- @since 0.0.0+text :: Cell Text+text = validate raw (first (Text.pack . show) . decodeUtf8')++{-# INLINE text #-}++-- | Parse something using its 'Read' instance via 'text'. Rejects @NULL@ values.+--+-- @since 0.0.0+readable :: Read a => Cell a+readable = validate text (first Text.pack . readEither . Text.unpack)++{-# INLINE readable #-}++-- | Validate the given cell parser.+--+-- @since 0.0.0+validate :: Cell a -> (a -> Either Text b) -> Cell b+validate (Cell run) f = Cell (run >=> first pure . f)++{-# INLINE validate #-}
+ lib/PostgreSQL/Result/Column.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Exports of this module are concerned with columns in a Postgres query result. This includes+-- validation of type and format. Parsing of the actual cell values in a column is delegated to+-- "PostgreSQL.Result.Cell".+module PostgreSQL.Result.Column+  ( -- * Column+    Column (..)++    -- ** Basics+  , ignored+  , raw+  , text+  , readable++    -- ** Helpful combinators+  , unchecked+  , validate+  , onlyTextual+  , onlyBinary++    -- * Class+  , AutoColumn (..)++    -- * Helpers+  , Readable (..)+  , RawValue (..)+  )+where++import           Data.ByteString (ByteString)+import           Data.Coerce (coerce)+import           Data.Functor.Alt (Alt (..))+import           Data.Text (Text)+import           Numeric.Natural (Natural)+import qualified PostgreSQL.Result.Cell as Cell+import           PostgreSQL.Types (Format (..), Oid (..), ParserError (..), ParserErrors, Value)++-- | Result column parser+--+-- @since 0.0.0+newtype Column a = Column+  { parseColumn+      :: Oid -- OID of the column type+      -> Format -- Format in which the cells of this column will appear+      -> Either ParserErrors (Cell.Cell a)+  }+  deriving stock Functor -- ^ @since 0.0.0++-- | @since 0.0.0+instance Alt Column where+  Column lhs <!> Column rhs = Column $ \typ format ->+    case (lhs typ format, rhs typ format) of+      (Right lhsParser, Right rhsParser) ->+        -- Both parsers at the column level succeeded. This means we must pass the alternation down+        -- to the cell-level parser.+        Right (lhsParser <!> rhsParser)++      (Left lhsErrors, Left rhsErrors) ->+        -- Both have failed, therefore we must combine the errors.+        Left (lhsErrors <> rhsErrors)++      (lhs, rhs) ->+        -- At this point we know that exactly one parser at the column level has failed.+        lhs <!> rhs++  {-# INLINE (<!>) #-}++-- | Lift a cell parser. This does perform any validation on column type or format.+--+-- @since 0.0.0+unchecked :: Cell.Cell a -> Column a+unchecked parser = Column $ \_ _ -> Right parser++{-# INLINE unchecked #-}++-- | Only allow textual format.+--+-- @since 0.0.0+onlyTextual :: Column a -> Column a+onlyTextual (Column run) = Column $ \oid format ->+  case format of+    Binary -> Left [UnsupportedFormat format]+    Text -> run oid format++{-# INLINE onlyTextual #-}++-- | Only allow binary format.+--+-- @since 0.0.0+onlyBinary :: Column a -> Column a+onlyBinary (Column run) = Column $ \oid format ->+  case format of+    Text -> Left [UnsupportedFormat format]+    Binary -> run oid format++{-# INLINE onlyBinary #-}++-- | Validate the result of a cell parser.+--+-- @since 0.0.0+validate :: Column a -> (a -> Either Text b) -> Column b+validate (Column run) f = Column $ \oid fmt -> do+  parser <- run oid fmt+  pure (Cell.validate parser f)++{-# INLINE validate #-}++-- | Don't parse the column.+--+-- @since 0.0.0+ignored :: Column ()+ignored = unchecked Cell.ignored++{-# INLINE ignored #-}++-- | Raw value. Rejects @NULL@.+--+-- @since 0.0.0+raw :: Column ByteString+raw = unchecked Cell.raw++{-# INLINE raw #-}++-- | Parse as UTF-8 'Text'. See 'Cell.text'.+--+-- @since 0.0.0+text :: Column Text+text = onlyTextual (unchecked Cell.text)++{-# INLINE text #-}++-- | Parse something using its 'Read' instance. Only supports textual format. See 'Cell.readable'.+--+-- @since 0.0.0+readable :: Read a => Column a+readable = onlyTextual (unchecked Cell.readable)++{-# INLINE readable #-}++-- | Default column parser for a type+--+-- @since 0.0.0+class AutoColumn a where+  -- | Default column parser for @a@+  --+  -- @since 0.0.0+  autoColumn :: Column a++-- | @since 0.0.0+instance AutoColumn () where+  autoColumn = ignored++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Int where+  autoColumn = readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Word where+  autoColumn = readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Integer where+  autoColumn = readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Natural where+  autoColumn = readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Float where+  autoColumn = readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Double where+  autoColumn = readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Oid where+  autoColumn = Oid <$> readable++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance AutoColumn Text where+  autoColumn = text++  {-# INLINE autoColumn #-}++-- | @since 0.0.0+instance (AutoColumn a, AutoColumn b) => AutoColumn (Either a b) where+  autoColumn = fmap Left autoColumn <!> fmap Right autoColumn++  {-# INLINE autoColumn #-}++-- | Provides a 'AutoColumn' instance using the 'Read' for @a@+--+-- @since 0.0.0+newtype Readable a = Readable a++-- | @since 0.0.0+instance Read a => AutoColumn (Readable a) where+  autoColumn = coerce (readable @a)++  {-# INLINE autoColumn #-}++-- | The raw cell value+--+-- @since 0.0.0+data RawValue = RawValue+  { rawValue_type :: Oid+  , rawValue_format :: Format+  , rawValue_value :: Value+  }+  deriving stock (Show, Eq, Ord)++-- | @since 0.0.0+instance AutoColumn RawValue where+  autoColumn = Column $ \oid format ->+    Right $ Cell.Cell $ Right . RawValue oid format++  {-# INLINE autoColumn #-}
+ lib/PostgreSQL/Result/Row.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Things in this module are used for processing Postgres query result rows.+module PostgreSQL.Result.Row+  ( Row+  , runRow+  , runRowPq++  , ColumnRequest (..)+  , ColumnPosition (..)++    -- * Combinators+  , column+  , columnWith+  , fixedColumn+  , fixedColumnWith+  , namedColumn+  , namedColumnWith++    -- * Class+  , AutoRow (..)+  , genericRow+  , AutoColumnDelegate++    -- * Helpers+  , Fixed (..)+  , Named (..)+  )+where++import           Control.Applicative (liftA2)+import           Control.Monad (when)+import qualified Control.Monad.Except as Except+import           Control.Monad.IO.Class (MonadIO (liftIO))+import qualified Control.Monad.Reader as Reader+import qualified Control.Monad.State.Strict as State+import           Data.Bifunctor (first)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as Char8+import           Data.Data (Proxy (..))+import           Data.Functor.Apply (Apply (..))+import           Data.Functor.Identity (Identity (..))+import           Data.Void (Void)+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified GHC.Generics as Generics+import           GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import           GHC.TypeNats (KnownNat, Nat, natVal)+import qualified PostgreSQL.Result.Cell as Cell+import qualified PostgreSQL.Result.Column as Column+import qualified PostgreSQL.Types as Types++-- | Position of a column+--+-- @since 0.0.0+data ColumnPosition+  = FixedColumn Types.ColumnNum+  -- ^ Column is at a fixed index.+  --+  -- @since 0.0.0+  | NamedColumn ByteString+  -- ^ Column has a fixed name.+  --+  -- @since 0.0.0+  deriving stock (Show, Read, Eq, Ord)++-- | Request a column+--+-- @since 0.0.0+data ColumnRequest a = ColumnReqest -- ^ @since 0.0.0+  { columnRequest_position :: ColumnPosition+  -- ^ Location of the column+  --+  -- @since 0.0.0+  , columnRequest_parser :: Column.Column a+  -- ^ Parser for the column+  --+  -- @since 0.0.0+  }+  deriving stock Functor++-- | Result row parser+--+-- @since 0.0.0+newtype Row a = Row+  { _unRow+      :: forall m row+      .  (Monad m, Applicative row)+      => (forall x. ColumnRequest x -> m (row x))+      -> State.StateT Types.ColumnNum m (row a)+  }++-- | @since 0.0.0+instance Functor Row where+  fmap f (Row run) = Row (\liftRequest -> fmap f <$> run liftRequest)++  {-# INLINE fmap #-}++-- | @since 0.0.0+instance Applicative Row where+  pure x = Row $ \_liftRequest -> pure $ pure x++  {-# INLINE pure #-}++  Row f <*> Row x = Row $ \liftRequest -> liftA2 (<*>) (f liftRequest) (x liftRequest)++  {-# INLINE (<*>) #-}++-- | @since 0.0.0+instance Apply Row where+  (<.>) = (<*>)++-- | Translate a 'Row' expression. Validate things in @m@ and parse each row in @row@.+--+-- @since 0.0.0+runRow+  :: (Monad m, Applicative row)+  => Row a+  -> (forall x. ColumnRequest x -> m (row x))+  -> m (row a)+runRow (Row run) liftRequest =+  State.evalStateT (run liftRequest) 0++{-# INLINE runRow #-}++-- | Generate a row runner for libpq\'s 'PQ.Result'.+--+-- @since 0.0.0+runRowPq+  :: (Except.MonadError Types.ProcessorErrors m, MonadIO m)+  => PQ.Result+  -> Row a+  -> m (Types.RowNum -> m a)+runRowPq result row = Reader.runReaderT <$> do+  numCols <- liftIO (PQ.nfields result)++  runRow row $ \req -> do+    col <-+      case columnRequest_position req of+        FixedColumn origCol@(Types.ColumnNum col) -> do+          when (col >= numCols) $+            Except.throwError [Types.NotEnoughColumns origCol (Types.ColumnNum numCols)]++          pure col++        NamedColumn name -> do+          mbCol <- liftIO (PQ.fnumber result name)+          maybe (Except.throwError [Types.MissingNamedColumn name]) pure mbCol++    oid <- liftIO (PQ.ftype result col)+    format <- liftIO (PQ.fformat result col)++    cell <-+      Except.liftEither $ first (fmap (Types.ColumnParserError (Types.ColumnNum col) oid format)) $+        Column.parseColumn (columnRequest_parser req) oid format++    pure $ Reader.ReaderT $ \(Types.RowNum row) -> do+      valueBare <- liftIO (PQ.getvalue' result row col)+      let value = maybe Types.Null Types.Value valueBare+      Except.liftEither+        $ first+            (fmap+              (Types.CellParserError+                (Types.ColumnNum col)+                oid+                format+                (Types.RowNum row)+                value))+        $ Cell.parseCell cell value++{-# INLINE runRowPq #-}++-- | Floating column using the default 'Column.Column' for @a@+--+-- The position of this column is depenend on other floating columns left of it.+--+-- For example:+--+-- > foo = baz <$> column <*> column <*> column+-- > --            ^ A        ^ B        ^ C+--+-- Here, @A@ would be at index 0, @B@ at 1 and @C@ at 2.+-- Other non-floating columns do not impact the column indices.+--+-- @since 0.0.0+column :: Column.AutoColumn a => Row a+column = columnWith Column.autoColumn++{-# INLINE column #-}++-- | Same as 'column' but lets you specify the 'Column.Column'.+--+-- @since 0.0.0+columnWith :: Column.Column a -> Row a+columnWith column = Row $ \liftRequest -> do+  col <- State.state (\col -> (col, col + 1))+  State.lift $ liftRequest ColumnReqest+    { columnRequest_position = FixedColumn col+    , columnRequest_parser = column+    }++{-# INLINE columnWith #-}++-- | Fixed-position column using the default 'Column.Column' for @a@+--+-- @since 0.0.0+fixedColumn :: Column.AutoColumn a => Types.ColumnNum -> Row a+fixedColumn num = fixedColumnWith num Column.autoColumn++{-# INLINE fixedColumn #-}++-- | Same as 'fixedColumn' but lets you specify the 'Column.Column'.+--+-- @since 0.0.0+fixedColumnWith :: Types.ColumnNum -> Column.Column a -> Row a+fixedColumnWith number column = Row $ \liftRequest -> State.lift $+  liftRequest ColumnReqest+    { columnRequest_position = FixedColumn number+    , columnRequest_parser = column+    }++{-# INLINE fixedColumnWith #-}++-- | Named column using the default 'Column.Column' for @a@+--+-- @since 0.0.0+namedColumn :: Column.AutoColumn a => ByteString -> Row a+namedColumn name = namedColumnWith name Column.autoColumn++{-# INLINE namedColumn #-}++-- | Same as 'namedColumn' but lets you specify the 'Column.Column'.+--+-- @since 0.0.0+namedColumnWith :: ByteString -> Column.Column a -> Row a+namedColumnWith name column = Row $ \liftRequest -> State.lift $+  liftRequest ColumnReqest+    { columnRequest_position = NamedColumn name+    , columnRequest_parser = column+    }++{-# INLINE namedColumnWith #-}++-- | Generic row parser+--+-- You can use this with your 'Generics.Generic'-implementing data types.+--+-- > data Foo = Foo+-- >   { bar :: Integer+-- >   , baz :: Text+-- >   }+-- >   deriving Generic+-- >+-- > fooRow :: Row Foo+-- > fooRow = genericRow+--+-- @since 0.0.0+genericRow :: (Generics.Generic a, AutoRow (Generics.Rep a Void)) => Row a+genericRow = Generics.to @_ @Void <$> autoRow++{-# INLINE genericRow #-}++-- | Value for a column at a fixed location+--+-- @since 0.0.0+newtype Fixed (index :: Nat) a = Fixed+  { fromFixed :: a }++-- | Value for a named column+--+-- @since 0.0.0+newtype Named (name :: Symbol) a = Named+  { fromNamed :: a }++-- | This class is used to intercept instance heads like 'Fixed' and 'Named' that have special+-- additional meaning. For most cases it will delegate to 'Column.AutoColumn'.+--+-- Use this class instead of 'Column.AutoColumn' when implementing 'AutoRow' instances.+--+-- @since 0.0.0+class AutoColumnDelegate a where+  autoColumnDelegate :: Row a++-- | Uses 'fixedColumn' with @index@ to construct the 'Row'+--+-- @since 0.0.0+instance (KnownNat index, Column.AutoColumn a) => AutoColumnDelegate (Fixed index a) where+  autoColumnDelegate = Fixed <$> fixedColumn (fromIntegral (natVal @index Proxy))++-- | Uses 'namedColumn' with @name@ to construct the 'Row'+--+-- @since 0.0.0+instance (KnownSymbol name, Column.AutoColumn a) => AutoColumnDelegate (Named name a) where+  autoColumnDelegate = Named <$> namedColumn (Char8.pack (symbolVal @name Proxy))++-- | Passthrough to 'Column.AutoColumn'+--+-- @since 0.0.0+instance {-# OVERLAPPABLE #-} Column.AutoColumn a => AutoColumnDelegate a where+  autoColumnDelegate = column++-- | Default row parser for a type+--+-- @since 0.0.0+class AutoRow a where+  -- | Default row parser for @a@+  --+  -- You may omit a definition for 'autoRow' if @a@ implements 'Generics.Generic'.+  --+  -- @since 0.0.0+  autoRow :: Row a++  default autoRow :: (Generics.Generic a, AutoRow (Generics.Rep a Void)) => Row a+  autoRow = genericRow++  {-# INLINE autoRow #-}++-- | @since 0.0.0+instance AutoColumnDelegate a => AutoRow (Generics.K1 tag a x) where+  autoRow = Generics.K1 <$> autoColumnDelegate++  {-# INLINE autoRow #-}++-- | @since 0.0.0+instance AutoRow (f x) => AutoRow (Generics.M1 tag meta f x) where+  autoRow = Generics.M1 <$> autoRow++  {-# INLINE autoRow #-}++-- | @since 0.0.0+instance (AutoRow (lhs x), AutoRow (rhs x)) => AutoRow ((Generics.:*:) lhs rhs x) where+  autoRow = (Generics.:*:) <$> autoRow <*> autoRow++  {-# INLINE autoRow #-}++-- | @since 0.0.0+instance AutoColumnDelegate a => AutoRow (Identity a)++-- | @since 0.0.0+instance+  ( AutoColumnDelegate a+  , AutoColumnDelegate b+  )+  => AutoRow (a, b)++-- | @since 0.0.0+instance+  ( AutoColumnDelegate a+  , AutoColumnDelegate b+  , AutoColumnDelegate c+  )+  => AutoRow (a, b, c)++-- | @since 0.0.0+instance+  ( AutoColumnDelegate a+  , AutoColumnDelegate b+  , AutoColumnDelegate c+  , AutoColumnDelegate d+  )+  => AutoRow (a, b, c, d)++-- | @since 0.0.0+instance+  ( AutoColumnDelegate a+  , AutoColumnDelegate b+  , AutoColumnDelegate c+  , AutoColumnDelegate d+  , AutoColumnDelegate e+  )+  => AutoRow (a, b, c, d, e)++-- | @since 0.0.0+instance+  ( AutoColumnDelegate a+  , AutoColumnDelegate b+  , AutoColumnDelegate c+  , AutoColumnDelegate d+  , AutoColumnDelegate e+  , AutoColumnDelegate f+  )+  => AutoRow (a, b, c, d, e, f)++-- | @since 0.0.0+instance+  ( AutoColumnDelegate a+  , AutoColumnDelegate b+  , AutoColumnDelegate c+  , AutoColumnDelegate d+  , AutoColumnDelegate e+  , AutoColumnDelegate f+  , AutoColumnDelegate g+  )+  => AutoRow (a, b, c, d, e, f, g)
+ lib/PostgreSQL/Statement.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Tools to deal with templates and statements are defined here.+module PostgreSQL.Statement+  ( Template+  , code+  , identifier+  , string+  , param+  , paramWith+  , constant++  , Statement (..)+  , renderTemplate++  , PreparedStatement (..)++  , tpl+  , stmt+  )+where++import           Control.Applicative ((<|>))+import           Control.Monad (join)+import qualified Control.Monad.State.Strict as State+import qualified Crypto.Hash as Hash+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as ByteString.Char8+import           Data.Char (isAlphaNum)+import           Data.Foldable (asum, fold)+import           Data.Functor.Contravariant (Contravariant (..))+import qualified Data.Sequence as Sequence+import           Data.String (IsString (..))+import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.Text.Encoding (encodeUtf8)+import           Data.Traversable (for)+import           Data.Void (Void)+import           GHC.OverloadedLabels (IsLabel (..))+import           GHC.Records (HasField (..))+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as Quote+import           Numeric.Natural (Natural)+import qualified PostgreSQL.Param as Param+import           PostgreSQL.Types (Oid)+import qualified Text.Megaparsec as Megaparsec+import qualified Text.Megaparsec.Char as Megaparsec.Char++data Segment a+  = Parameter (Param.Info (a -> Param.Value))+  | Code Text++instance Contravariant Segment where+  contramap f = \case+    Parameter g -> Parameter $ fmap (. f) g+    Code text -> Code text++  {-# INLINE contramap #-}++-- | SQL statement template+--+-- @since 0.0.0+newtype Template a = Template+  { _unStatement :: Sequence.Seq (Segment a) }+  deriving newtype+    ( Semigroup -- ^ @since 0.0.0+    , Monoid -- ^ @since 0.0.0+    )++-- | @since 0.0.0+instance Contravariant Template where+  contramap f (Template seqs) = Template (fmap (contramap f) seqs)++  {-# INLINE contramap #-}++-- | @OverloadedStrings@ helper for 'code'+--+-- > "my code" === code "my code"+--+-- @since 0.0.0+instance IsString (Template a) where+  fromString = code . Text.pack++  {-# INLINE fromString #-}++-- | @OverloadedLabels@ helper for 'param'+--+-- > #myParam === param (getField @"myParam")+--+-- Use this with a database:+--+-- > data MyFoo = MyFoo { bar :: Int, baz :: String }+-- >+-- > myStatementTpl :: Template MyFoo+-- > myStatementTpl = "SELECT * FROM my_foo WHERE bar = " <> #bar <> " AND baz = " <> #baz+--+--+-- @since 0.0.0+instance (HasField n r a, Param.Param a) => IsLabel n (Template r) where+  fromLabel = param (getField @n @r @a)++  {-# INLINE fromLabel #-}++-- | Create a code-only statement.+--+-- @since 0.0.0+code :: Text -> Template a+code = Template . Sequence.singleton . Code++{-# INLINE code #-}++-- | Create a code segment that mentions the given identifier (e.g. table or column name).+--+-- @since 0.0.0+identifier :: Text -> Template a+identifier name =+  code $ Text.concat ["\"", safeName, "\""]+  where+    safeName = Text.intercalate "\"\"" $ Text.split (== '"') name++{-# INLINE identifier #-}++-- | Encase the given string literal in single quotes. Single quotes in the literal are+-- automatically escaped.+--+-- @since 0.0.0+string :: Text -> Template a+string str = "'" <> code (Text.replace "'" "''" str) <> "'"++{-# INLINE string #-}++-- | Annotate the given statement with a type signature.+annotateParamType :: Maybe Text -> Template a -> Template a+annotateParamType typeAnnotation stmt =+  case typeAnnotation of+    Just paramType -> "(" <> stmt <> code (" :: " <> paramType <> ")")+    Nothing -> stmt++{-# INLINE annotateParamType #-}++-- | Reference a parameter.+--+-- @since 0.0.0+param :: forall b a. Param.Param b => (a -> b) -> Template a+param f = paramWith $ fmap (. f) $ Param.paramInfo @b++{-# INLINE param #-}++-- | Reference a parameter.+--+-- @since 0.0.0+paramWith :: Param.Info (a -> Param.Value) -> Template a+paramWith info =+  annotateParamType (Param.info_typeName info) $ Template $ Sequence.singleton $ Parameter info++{-# INLINE paramWith #-}++-- | Constant part of a query.+--+-- @since 0.0.0+constant :: forall b a. Param.Param b => b -> Template a+constant x = paramWith $ fmap (. const x) $ Param.paramInfo @b++{-# INLINE constant #-}++-- | Rendered SQL statement+--+-- @since 0.0.0+data Statement a = Statement+  { statement_code :: ByteString+  , statement_mkParams :: a -> [Param.PackedParam]+  , statement_types :: [Oid]+  , statement_name :: ByteString+  }++-- | @since 0.0.0+instance Contravariant Statement where+  contramap f statement = Statement+    { statement_code = statement_code statement+    , statement_mkParams = statement_mkParams statement . f+    , statement_types = statement_types statement+    , statement_name = statement_name statement+    }++  {-# INLINE contramap #-}++-- | Render the SQL statement.+--+-- @since 0.0.0+renderTemplate :: Template a -> Statement a+renderTemplate (Template segments :: Template a) = Statement+  { statement_code = codeBytes+  , statement_mkParams = mkParams+  , statement_types = types+  , statement_name = ByteString.Char8.pack (show hash)+  }+  where+    code :: Text+    code = fold $ flip State.evalState (1 :: Natural) $ for segments $ \case+      Parameter _ -> do+        index <- State.state $ \i -> (i, i + 1)+        pure $ Text.pack $ '$' : show index++      Code text ->+        pure text++    codeBytes :: ByteString+    codeBytes = encodeUtf8 code++    mkParams :: a -> [Param.PackedParam]+    mkParams input =+      foldr+        (\case+          Parameter info -> (Param.packParam (fmap ($ input) info) :)+          Code{} -> id+        )+        []+        segments++    types :: [Oid]+    types =+      foldr+        (\case+          Parameter info -> (Param.typeOid (Param.info_type info) :)+          Code{} -> id+        )+        []+        segments++    hash :: Hash.Digest Hash.SHA224+    hash =+      Hash.hashFinalize $ Hash.hashUpdates Hash.hashInit $+        codeBytes : map (ByteString.Char8.pack . show) types++{-# INLINE renderTemplate #-}++---++-- | Prepared statement+--+-- @since 0.0.0+data PreparedStatement a = PreparedStatement+  { preparedStatement_name :: ByteString+  , preparedStatement_mkParams :: a -> [Param.PackedParamPrepared]+  }++-- | @since 0.0.0+instance Contravariant PreparedStatement where+  contramap f statement = PreparedStatement+    { preparedStatement_name = preparedStatement_name statement+    , preparedStatement_mkParams = preparedStatement_mkParams statement . f+    }++---++parseName :: Megaparsec.Parsec Void String String+parseName =+  Megaparsec.takeWhile1P Nothing $ \c ->+    isAlphaNum c || elem @[] c "_'"++data QuoteSegment+  = QuoteCode String+  | QuoteParam String+  | QuoteSubst String++parseQuote :: Megaparsec.Parsec Void String (TH.Q TH.Exp)+parseQuote =+  combine <$> Megaparsec.many (asum [nonSegment, dollar, interactive])+  where+    nonSegment = QuoteCode <$> Megaparsec.takeWhile1P Nothing (/= '$')++    dollar = QuoteCode "$" <$ Megaparsec.Char.string "$$"++    between lhs inner rhs =+      Megaparsec.between (Megaparsec.Char.char lhs) (Megaparsec.Char.char rhs) inner++    interactive = do+      _ <- Megaparsec.Char.char '$'+      asum+        [ QuoteSubst <$> between '(' parseName ')'+        , QuoteParam <$> (between '{' parseName '}' <|> parseName)+        ]++    combine segments = do+      segments <- for segments $ pure . \case+        QuoteCode code ->+          [e| fromString $(TH.stringE code) |]++        QuoteParam paramCode ->+          integrateAsParam paramCode++        QuoteSubst paramCode ->+          integrateAsSubst paramCode++      [e| mconcat $(TH.listE segments) |]++integrateAsParam :: String -> TH.ExpQ+integrateAsParam paramCode =+  [e| PostgreSQL.Statement.param $(TH.varE (TH.mkName paramCode)) |]++integrateAsSubst :: String -> TH.ExpQ+integrateAsSubst paramCode =+  TH.varE (TH.mkName paramCode)++tplQuoteExp :: String -> TH.Q TH.Exp+tplQuoteExp contents = do+  join $ either (fail . Megaparsec.errorBundlePretty) pure $+    Megaparsec.parse+      (parseQuote <* Megaparsec.eof)+      "(PostgreSQL.Statement.tpl quasi-quotation)"+      contents++-- | Produces a 'Template' expression.+--+-- Supports the same features as 'stmt'.+--+-- @since 0.0.0+tpl :: Quote.QuasiQuoter+tpl = Quote.QuasiQuoter+  { Quote.quoteExp = tplQuoteExp+  , Quote.quotePat = error "'tpl' cannot be used in a pattern"+  , Quote.quoteType = error "'tpl' cannot be used in a type"+  , Quote.quoteDec = error "'tpl' cannot be used in a declaration"+  }++stmtQuoteExp :: String -> TH.Q TH.Exp+stmtQuoteExp contents = do+  stmt <- either (fail . Megaparsec.errorBundlePretty) pure $+    Megaparsec.parse+      (parseQuote <* Megaparsec.eof)+      "(PostgreSQL.Statement.stmt quasi-quotation)"+      contents+  [e| renderTemplate $stmt |]++-- | Produces a 'Statement' expression.+--+-- > [stmt| SELECT $param * 2 |]+--+-- Use @$$@ to render a single @$@.+--+-- == Parameters+--+-- Use @$param@ or @${param}@ to reference a query parameter.+--+-- @[stmt| ${x} |]@ is equivalent to @'param' x@.+--+-- == Substitutions+--+-- Use @$(substr)@ to embed another 'Template' where @substr :: 'Template' a@.+--+-- @[stmt| $(x) |]@ is equivalent to @x@.+--+-- == Examples+--+-- > data MyParams = MyParams { foo :: Int, bar :: Text }+-- >+-- > myStatement :: Statement MyParams+-- > myStatement = [stmt| SELECT baz FROM my_table WHERE foo > ${foo} AND bar = ${bar} |]+--+-- @since 0.0.0+stmt :: Quote.QuasiQuoter+stmt = Quote.QuasiQuoter+  { Quote.quoteExp = stmtQuoteExp+  , Quote.quotePat = error "'stmt' cannot be used in a pattern"+  , Quote.quoteType = error "'stmt' cannot be used in a type"+  , Quote.quoteDec = error "'stmt' cannot be used in a declaration"+  }
+ lib/PostgreSQL/Types.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++-- | The various common types commonly used throughout this package are exported here.+module PostgreSQL.Types+  ( Value (..)+  , RegType (..)+  , PackedParam (..)+  , PackedParamPrepared (..)+  , ParserError (..)+  , ParserErrors+  , ProcessorError (..)+  , ProcessorErrors+  , ResultError (..)+  , ResultErrors+  , Error (..)+  , Errors+  , ColumnNum (..)+  , RowNum (..)++    -- * Re-exports+  , PQ.Format (..)+  , PQ.Oid (..)+  , PQ.Connection+  )+where++import           Control.Exception (Exception)+import           Data.ByteString (ByteString)+import           Data.List.NonEmpty (NonEmpty)+import           Data.String (IsString (..))+import           Data.Text (Text)+import qualified Database.PostgreSQL.LibPQ as PQ+import           Foreign.C.Types (CInt)++-- | Value+--+-- @since 0.0.0+data Value+  = Null+  | Value ByteString+  deriving stock+    ( Show -- ^ @since 0.0.0+    , Eq -- ^ @since 0.0.0+    , Ord -- ^ @since 0.0.0+    )++-- | @since 0.0.0+instance IsString Value where+  fromString = Value . fromString++-- | Postgre's regtype+--+-- @since 0.0.0+newtype RegType = RegType+  { unRegType :: Text }+  deriving newtype+    ( Show -- ^ @since 0.0.0+    , Read -- ^ @since 0.0.0+    , Eq -- ^ @since 0.0.0+    , Ord -- ^ @since 0.0.0+    , IsString -- ^ @since 0.0.0+    )++-- | Packed parameter+--+-- @since 0.0.0+newtype PackedParam = PackedParam (Maybe (PQ.Oid, ByteString, PQ.Format))+  deriving newtype Show -- ^ @since 0.0.0++-- | Packed parameter for a prepared query+--+-- @since 0.0.0+newtype PackedParamPrepared = PackedParamPrepared (Maybe (ByteString, PQ.Format))+  deriving newtype Show -- ^ @since 0.0.0++-- | Error that occurs when parsing a column+--+-- @since 0.0.0+data ParserError+  = UnsupportedFormat PQ.Format+  | UnsupportedOid PQ.Oid+  deriving stock+    ( Show -- ^ @since 0.0.0+    , Eq -- ^ @since 0.0.0+    , Ord -- ^ @since 0.0.0+    )++type ParserErrors = NonEmpty ParserError++-- | Error that may occur during processing+--+-- @since 0.0.0+data ProcessorError+  = ColumnParserError+    { processorError_column :: ColumnNum+    , processorError_type :: PQ.Oid+    , processorError_format :: PQ.Format+    , processorError_columnError :: ParserError+    }+  | CellParserError+    { processorError_column :: ColumnNum+    , processorError_type :: PQ.Oid+    , processorError_format :: PQ.Format+    , processorError_row :: RowNum+    , processorError_value :: Value+    , processorError_cellError :: Text+    }+  | NotEnoughColumns+    { processorError_wantedColumns :: ColumnNum+    , processorError_haveColumns :: ColumnNum+    }+  | MissingNamedColumn+    { processorError_wantedColumnName :: ByteString+    }+  deriving stock+    ( Show -- ^ @since 0.0.0+    , Eq -- ^ @since 0.0.0+    , Ord -- ^ @since 0.0.0+    )++type ProcessorErrors = NonEmpty ProcessorError++-- | Error that occurs when validating the result+--+-- @since 0.0.0+data ResultError+  = BadResultStatus+    { resultError_status :: ByteString }+  | NoRows+  | MultipleRows+    { resultError_numRows :: RowNum }+  | FailedToParseAffectedRows+    { resultError_message :: Text }+  deriving stock+    ( Show -- ^ @since 0.0.0+    , Eq -- ^ @since 0.0.0+    , Ord -- ^ @since 0.0.0+    )+++type ResultErrors = NonEmpty ResultError++-- | @since 0.0.0+data Error+  = ErrorDuringProcessing ProcessorError+  -- ^ Occurs when processing the result table+  | ErrorDuringValidation ResultError+  -- ^ Occurs when validating the result object+  deriving stock+    ( Show -- ^ @since 0.0.0+    , Eq -- ^ @since 0.0.0+    , Ord -- ^ @since 0.0.0+    )+  deriving anyclass Exception -- ^ @since 0.0.0++type Errors = NonEmpty Error++-- | Numberic column identifier+--+-- @since 0.0.0+newtype ColumnNum = ColumnNum+  { fromColumnNum :: PQ.Column }+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Num, Integral, Real) via CInt++-- | Numberic row identifier+--+-- @since 0.0.0+newtype RowNum = RowNum+  { fromRowNum :: PQ.Row }+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Num, Integral, Real) via CInt
+ psql.cabal view
@@ -0,0 +1,76 @@+cabal-version:      2.2+name:               psql+version:            0.0.0+category:           Database+synopsis:           PostgreSQL client+description:        This package defines a PostgreSQL client.+                    .+                    Check out the "PostgreSQL" module for a documentation overview.+author:             Ole Krüger <haskell-psql@vprsm.de>+maintainer:         Ole Krüger <haskell-psql@vprsm.de>+homepage:           https://github.com/vapourismo/psql+license:            BSD-3-Clause+license-file:       LICENSE+extra-source-files: ChangeLog.md+build-type:         Simple++source-repository head+  type:     git+  location: git://github.com/vapourismo/psql.git++common warnings+  ghc-options: -Wall -Wextra -Wno-name-shadowing -Wredundant-constraints++library+  import:           warnings+  default-language: Haskell2010+  build-depends:    base >= 4.13 && < 5,+                    bytestring,+                    concurrency,+                    containers,+                    cryptonite,+                    exceptions,+                    megaparsec,+                    mtl,+                    postgresql-libpq,+                    -- FIXME: semigroupoids version needed is not on Hackage yet+                    semigroupoids,+                    simpoole >= 0.4.0,+                    template-haskell,+                    text,+                    vector+  hs-source-dirs:   lib+  exposed-modules:  PostgreSQL+                    PostgreSQL.Class+                    PostgreSQL.ConnectionPool+                    PostgreSQL.Param+                    PostgreSQL.Query+                    PostgreSQL.Query.Class+                    PostgreSQL.Result+                    PostgreSQL.Result.Cell+                    PostgreSQL.Result.Column+                    PostgreSQL.Result.Row+                    PostgreSQL.Statement+                    PostgreSQL.Types++test-suite psql-tests+  import:           warnings+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  ghc-options:      -threaded -with-rtsopts=-N+  build-depends:    base,+                    bytestring,+                    cgroup-rts-threads,+                    exceptions,+                    hspec,+                    mtl,+                    postgresql-libpq,+                    psql,+                    semigroupoids,+                    sop-core,+                    unordered-containers,+                    vector,+                    massiv+  hs-source-dirs:   test+  main-is:          Main.hs+  other-modules:    PostgreSQL.Result.RowSpec
+ test/Main.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import           Control.Concurrent.CGroup (initRTSThreads)+import qualified PostgreSQL.Result.RowSpec+import           Test.Hspec (describe, hspec)++main :: IO ()+main = do+  initRTSThreads+  hspec $+    describe "PostgreSQL.Row" PostgreSQL.Result.RowSpec.spec
+ test/PostgreSQL/Result/RowSpec.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module PostgreSQL.Result.RowSpec (spec) where++import Test.Hspec (Spec, describe, it, shouldBe)++import           Control.Monad (when)+import qualified Control.Monad.Except as Except+import qualified Control.Monad.Reader as Reader+import           Data.Bifunctor (first)+import           Data.ByteString (ByteString)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Massiv.Array as Massiv+import           Data.Traversable (for)+import qualified Data.Vector as Vector+import           Database.PostgreSQL.LibPQ (Format (Text), Oid, invalidOid)+import qualified PostgreSQL.Result.Cell as Cell+import qualified PostgreSQL.Result.Column as Column+import qualified PostgreSQL.Result.Row as Row+import           PostgreSQL.Types (ColumnNum, ProcessorError (..), ProcessorErrors, Value (..))++type Matrix = Massiv.Array Massiv.B Massiv.Ix2++runMatrixRow+  :: Vector.Vector (Oid, Format)+  -> HashMap.HashMap ByteString ColumnNum+  -> Matrix Value+  -> Row.Row a+  -> Either ProcessorErrors [a]+runMatrixRow columns names datas row = Except.runExcept $ do+  let+    Massiv.Sz2 numRows' numCols' = Massiv.size datas++    numRows = fromIntegral numRows'++    numCols = min (fromIntegral numCols') $ fromIntegral $ Vector.length columns++  runner <- Row.runRow row $ \req -> do+    col <-+      case Row.columnRequest_position req of+        Row.FixedColumn col -> pure col++        Row.NamedColumn name ->+          case HashMap.lookup name names of+            Just col -> pure col+            Nothing -> Except.throwError [MissingNamedColumn name]++    when (col >= numCols) $ Except.throwError [NotEnoughColumns col numCols]++    let (oid, format) = columns Vector.! fromIntegral col++    cell <-+      Except.liftEither $ first (fmap (ColumnParserError col oid format)) $+        Column.parseColumn (Row.columnRequest_parser req) oid format++    pure $ Reader.ReaderT $ \row -> do+      let value = Massiv.index' datas $ Massiv.Ix2 (fromIntegral row) $ fromIntegral col+      Except.liftEither $ first (fmap (CellParserError col oid format row value)) $+        Cell.parseCell cell value++  for [0 .. numRows - 1] (Reader.runReaderT runner)++spec :: Spec+spec =+  describe "Row" $ do+    it "works as an Applicative" $+      runMatrixRow [] [] [[], []] (pure ())+        `shouldBe` Right [(), ()]++    it "works on single columns" $+      runMatrixRow+        [(invalidOid, Text)]+        []+        [["Hello"], ["World"]]+        (Row.columnWith Column.raw)+        `shouldBe` Right ["Hello", "World"]++    it "works on multiple columns" $+      runMatrixRow+        [(invalidOid, Text), (invalidOid, Text)]+        []+        [["1", "Hello"], ["2", "World"]]+        (replicate <$> Row.column <*> Row.columnWith Column.raw)+        `shouldBe` Right [["Hello"], ["World", "World"]]++    it "resolves named columns" $+      runMatrixRow+        [(invalidOid, Text), (invalidOid, Text)]+        [("b", 1)]+        [["1", "Hello"], ["2", "World"]]+        (Row.namedColumnWith "b" Column.raw)+        `shouldBe` Right ["Hello", "World"]++    it "works with fixed columns" $+      runMatrixRow+        [(invalidOid, Text), (invalidOid, Text)]+        []+        [["1", "Hello"], ["2", "World"]]+        (Row.fixedColumnWith 1 Column.raw)+        `shouldBe` Right ["Hello", "World"]++    it "fails on too few columns" $+      runMatrixRow+        [(invalidOid, Text)]+        []+        [["Hello"]]+        (Row.fixedColumnWith 1 Column.raw)+        `shouldBe` Left [NotEnoughColumns 1 1]++    it "fails on unknown named column" $+      runMatrixRow+        [(invalidOid, Text)]+        []+        [["Hello"]]+        (Row.namedColumnWith "unknown" Column.raw)+        `shouldBe` Left [MissingNamedColumn "unknown"]