diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# psql + +## 0.0.0 + +This is the root version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/lib/PostgreSQL.hs b/lib/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL.hs @@ -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. +-- diff --git a/lib/PostgreSQL/Class.hs b/lib/PostgreSQL/Class.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Class.hs @@ -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 #-} diff --git a/lib/PostgreSQL/ConnectionPool.hs b/lib/PostgreSQL/ConnectionPool.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/ConnectionPool.hs @@ -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 diff --git a/lib/PostgreSQL/Param.hs b/lib/PostgreSQL/Param.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Param.hs @@ -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 + } diff --git a/lib/PostgreSQL/Query.hs b/lib/PostgreSQL/Query.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Query.hs @@ -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 #-} diff --git a/lib/PostgreSQL/Query/Class.hs b/lib/PostgreSQL/Query/Class.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Query/Class.hs @@ -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 #-} diff --git a/lib/PostgreSQL/Result.hs b/lib/PostgreSQL/Result.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Result.hs @@ -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 #-} diff --git a/lib/PostgreSQL/Result/Cell.hs b/lib/PostgreSQL/Result/Cell.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Result/Cell.hs @@ -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 #-} diff --git a/lib/PostgreSQL/Result/Column.hs b/lib/PostgreSQL/Result/Column.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Result/Column.hs @@ -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 #-} diff --git a/lib/PostgreSQL/Result/Row.hs b/lib/PostgreSQL/Result/Row.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Result/Row.hs @@ -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) diff --git a/lib/PostgreSQL/Statement.hs b/lib/PostgreSQL/Statement.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Statement.hs @@ -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" + } diff --git a/lib/PostgreSQL/Types.hs b/lib/PostgreSQL/Types.hs new file mode 100644 --- /dev/null +++ b/lib/PostgreSQL/Types.hs @@ -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 diff --git a/psql.cabal b/psql.cabal new file mode 100644 --- /dev/null +++ b/psql.cabal @@ -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 +maintainer: Ole Krüger +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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/PostgreSQL/Result/RowSpec.hs b/test/PostgreSQL/Result/RowSpec.hs new file mode 100644 --- /dev/null +++ b/test/PostgreSQL/Result/RowSpec.hs @@ -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"]