diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +# 0.3 (2020-06-18) + +- lookup types by name when OID is not known statically +- specify isolation level when running a transaction +- stop trying to fake nested transactions +- provide direct access to a Connection when that control is needed + +# 0.2 (2020-03-31) + +- now we have documentation +- rearrange some code, re-export modules to support docs + # 0.1 (2020-02-29) 0.1 highlights include: diff --git a/preql.cabal b/preql.cabal --- a/preql.cabal +++ b/preql.cabal @@ -1,111 +1,125 @@ cabal-version: 1.18 -name: preql -version: 0.2 -license: BSD3 -license-file: LICENSE -maintainer: bergey@teallabs.org -author: Daniel Bergey -homepage: https://github.com/bergey/preql#readme -bug-reports: https://github.com/bergey/preql/issues -synopsis: safe PostgreSQL queries using Quasiquoters -description: - Before you Post(gres)QL, preql. - . - @preql@ provides a low-level interface to PostgreSQL and a quasiquoter that converts - inline variable names to SQL parameters. Higher-level interfaces, checking SQL syntax & - schema, are planned. - . - the [quickstart](https://github.com/bergey/preql#quickstart) - or the [vision](https://github.com/bergey/preql#vision-parsing-sql-in-haskell-quasiquotes) - . - Most applications will want to import the top-level module @Preql@. When writing @SQL@ - instances or your own higher-level abstractions, you may want the lower-level, - IO-specific functions in @Preql.Wire@, not all of which are re-exported from @Preql@. - . -category: Database, PostgreSQL -build-type: Simple -extra-doc-files: CHANGELOG.md +-- This file has been generated from package.yaml by hpack version 0.33.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9ee4ad1565dfa854b29bb325c372b2238843844d5c1f93696d018675540809e9 + +name: preql +version: 0.3 +synopsis: safe PostgreSQL queries using Quasiquoters +description: Before you Post(gres)QL, preql. + . + @preql@ provides a low-level interface to PostgreSQL and a quasiquoter that converts + inline variable names to SQL parameters. Higher-level interfaces, checking SQL syntax & + schema, are planned. + . + the [quickstart](https://github.com/bergey/preql#quickstart) + or the [vision](https://github.com/bergey/preql#vision-parsing-sql-in-haskell-quasiquotes) + . + Most applications will want to import the top-level module @Preql@. When writing @SQL@ + instances or your own higher-level abstractions, you may want the lower-level, + IO-specific functions in @Preql.Wire@, not all of which are re-exported from @Preql@. + . +category: Database, PostgreSQL +homepage: https://github.com/bergey/preql#readme +bug-reports: https://github.com/bergey/preql/issues +author: Daniel Bergey +maintainer: bergey@teallabs.org +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-doc-files: + CHANGELOG.md + source-repository head - type: git - location: https://github.com/bergey/preql + type: git + location: https://github.com/bergey/preql library - exposed-modules: - Preql - Preql.Effect - Preql.Effect.Internal - Preql.Imports - Preql.QuasiQuoter.Raw.Lex - Preql.QuasiQuoter.Raw.TH - Preql.Wire - Preql.Wire.Errors - Preql.Wire.FromSql - Preql.Wire.Internal - Preql.Wire.Orphans - Preql.Wire.Query - Preql.Wire.ToSql - Preql.Wire.Tuples - Preql.Wire.TypeInfo.Static - Preql.Wire.TypeInfo.Types - Preql.Wire.Types - build-tools: alex -any, happy -any - hs-source-dirs: src - other-modules: - Paths_preql - default-language: Haskell2010 - default-extensions: OverloadedStrings - build-depends: - aeson >=1.3.1 && <1.5, - array >=0.5.2 && <0.6, - base >=4.11 && <4.14, - binary-parser >=0.5.5 && <0.6, - bytestring >=0.10.8 && <0.11, - bytestring-strict-builder >=0.4.5 && <0.5, - contravariant >=1.4.1 && <1.6, - free >=5.0.2 && <5.2, - mtl >=2.2.2 && <2.3, - postgresql-binary >=0.12.1 && <0.13, - postgresql-libpq >=0.9.4 && <0.10, - scientific >=0.3.6 && <0.4, - template-haskell >=2.13.0 && <2.16, - text >=1.2.3 && <1.3, - th-lift-instances >=0.1.11 && <0.2, - time >=1.8.0 && <1.10, - transformers >=0.5.5 && <0.6, - uuid >=1.3.13 && <1.4, - vector >=0.12.0 && <0.13 + exposed-modules: + Preql + Preql.Effect + Preql.Effect.Internal + Preql.Imports + Preql.QuasiQuoter.Raw.Lex + Preql.QuasiQuoter.Raw.TH + Preql.Wire + Preql.Wire.Errors + Preql.Wire.FromSql + Preql.Wire.Internal + Preql.Wire.Orphans + Preql.Wire.Query + Preql.Wire.ToSql + Preql.Wire.Tuples + Preql.Wire.TypeInfo.Static + Preql.Wire.TypeInfo.Types + Preql.Wire.Types + other-modules: + Paths_preql + hs-source-dirs: + src + default-extensions: OverloadedStrings + build-tools: + alex + , happy + build-depends: + aeson >=1.3.1 && <1.6 + , array >=0.5.2 && <0.6 + , base >=4.11 && <4.15 + , binary-parser >=0.5.5 && <0.6 + , bytestring >=0.10.8 && <0.11 + , bytestring-strict-builder >=0.4.5 && <0.5 + , contravariant >=1.4.1 && <1.6 + , free >=5.0.2 && <5.2 + , mtl >=2.2.2 && <2.3 + , postgresql-binary >=0.12.1 && <0.13 + , postgresql-libpq >=0.9.4 && <0.10 + , scientific >=0.3.6 && <0.4 + , template-haskell >=2.13.0 && <2.17 + , text >=1.2.3 && <1.3 + , th-lift-instances >=0.1.11 && <0.2 + , time >=1.8.0 && <1.10 + , transformers >=0.5.5 && <0.6 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + default-language: Haskell2010 test-suite tests - type: exitcode-stdio-1.0 - main-is: Test.hs - build-tools: alex -any, happy -any - hs-source-dirs: test - other-modules: - Test.Wire - Paths_preql - default-language: Haskell2010 - default-extensions: OverloadedStrings - build-depends: - aeson >=1.3.1 && <1.5, - array >=0.5.2 && <0.6, - base >=4.11 && <4.14, - binary-parser >=0.5.5 && <0.6, - bytestring <0.11, - bytestring-strict-builder >=0.4.5 && <0.5, - contravariant >=1.4.1 && <1.6, - free >=5.0.2 && <5.2, - mtl >=2.2.2 && <2.3, - postgresql-binary >=0.12.1 && <0.13, - postgresql-libpq <0.10, - preql -any, - scientific >=0.3.6 && <0.4, - tasty <1.3, - tasty-hunit <0.11, - template-haskell >=2.13.0 && <2.16, - text <1.3, - th-lift-instances >=0.1.11 && <0.2, - time >=1.8.0 && <1.10, - transformers >=0.5.5 && <0.6, - uuid <1.4, - vector <0.13 + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Test.Wire + Test.Wire.Enum + Paths_preql + hs-source-dirs: + test + default-extensions: OverloadedStrings + build-tools: + alex + , happy + build-depends: + aeson >=1.3.1 && <1.6 + , array >=0.5.2 && <0.6 + , base >=4.11 && <4.15 + , binary-parser >=0.5.5 && <0.6 + , bytestring >=0.10.8 && <0.11 + , bytestring-strict-builder >=0.4.5 && <0.5 + , contravariant >=1.4.1 && <1.6 + , free >=5.0.2 && <5.2 + , mtl >=2.2.2 && <2.3 + , postgresql-binary >=0.12.1 && <0.13 + , postgresql-libpq >=0.9.4 && <0.10 + , preql + , scientific >=0.3.6 && <0.4 + , tasty >=1.1 && <1.4 + , tasty-hunit >=0.10 && <0.11 + , template-haskell >=2.13.0 && <2.17 + , text >=1.2.3 && <1.3 + , th-lift-instances >=0.1.11 && <0.2 + , time >=1.8.0 && <1.10 + , transformers >=0.5.5 && <0.6 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + default-language: Haskell2010 diff --git a/src/Preql/Effect.hs b/src/Preql/Effect.hs --- a/src/Preql/Effect.hs +++ b/src/Preql/Effect.hs @@ -1,8 +1,149 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + -- | SQL Effect class, basically capturing some way of accessing a database. module Preql.Effect - ( Query, SQL(..), Transaction, runTransactionIO + ( module Preql.Effect, Transaction ) where import Preql.Effect.Internal -import Preql.Wire.Internal +import Preql.Imports +import Preql.Wire + +import Control.Exception (throwIO) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT) +import Database.PostgreSQL.LibPQ (Connection) +import qualified Control.Monad.Trans.State.Lazy as SL +import qualified Control.Monad.Trans.State.Strict as SS +import qualified Control.Monad.Trans.RWS.Lazy as L +import qualified Control.Monad.Trans.RWS.Strict as S + +import qualified Preql.Wire.Query as W + +-- | An Effect class for running SQL queries. You can think of this as a context +-- specifying a particular Postgres connection (or connection pool). A minimal instance +-- defines @withConnection@. +-- +-- Override the remaining methods to log errors before rethrowing, or not to rethrow. +class SqlQuery m => SQL (m :: * -> *) where + -- | Run multiple queries in a transaction. + runTransaction' :: IsolationLevel -> Transaction a -> m a + default runTransaction' :: MonadIO m => IsolationLevel -> Transaction a -> m a + runTransaction' level t = withConnection $ \conn -> + liftIO $ either throwIO pure =<< runTransactionIO level t conn + + -- | @runTransaction@ covers the most common patterns of + -- mult-statement transactions. @withConnection@ is useful when + -- you want more control, or want to override the defaults that + -- your instance defines. For example: + -- - change the number of retries + -- - interleave calls to other services with the Postgres transaction + -- - ensure a prepared statement is shared among successive transactions + withConnection :: (Connection -> m a) -> m a + + -- | Run a query on the specified 'Connection' + queryOn :: (ToSql p, FromSql r) => Connection -> (Query, p) -> m (Vector r) + default queryOn :: (ToSql p, FromSql r, MonadIO m) => Connection -> (Query, p) -> m (Vector r) + queryOn conn (q, p) = liftIO $ either throwIO pure =<< W.query conn q p + + queryOn_ :: ToSql p => Connection -> (Query, p) -> m () + default queryOn_ :: (ToSql p, MonadIO m) => Connection -> (Query, p) -> m () + queryOn_ conn (q, p) = liftIO $ either throwIO pure =<< W.query_ conn q p + +-- | Run a Transaction with full Serializable isolation. +runTransaction :: SQL m => Transaction a -> m a +runTransaction = runTransaction' Serializable + +-- | SqlQuery is separate from 'SQL' so that nested 'Transaction's are +-- statically prevented. @query@ can be used directly within any +-- 'SQL' monad (running a single-statement transaction), or within a +-- 'Transaction'. +-- +-- Users should not need to define instances, as every @SQL@ instance +-- implies a @SqlQuery@ instance. +class Monad m => SqlQuery (m :: * -> *) where + -- | Run a parameterized query that returns data. The tuple argument is typically provided by + -- the 'sql' Quasiquoter. + query :: (ToSql p, FromSql r) => (Query, p) -> m (Vector r) + + -- | Run a parameterized query that does not return data. + query_ :: ToSql p => (Query, p) -> m () + +-- | Most larger applications will define an instance; this one is suitable to test out the library. +instance SQL (ReaderT Connection IO) where + withConnection = (ask >>=) + +instance {-# OVERLAPPABLE #-} (Monad m, SQL m) => SqlQuery m where + query qp = withConnection (\conn -> queryOn conn qp) + query_ q = withConnection (\conn -> queryOn_ conn q) + +-- * Transactions + +-- | Run the provided 'Transaction'. If it fails with a 'QueryError', roll back. +runTransactionIO :: IsolationLevel -> Transaction a -> Connection -> IO (Either QueryError a) +runTransactionIO level (Transaction m) conn = do + either throwIO pure =<< W.begin conn level + e_a <- runReaderT (runExceptT m) conn + void $ case e_a of + Left _ -> W.rollback conn + Right _ -> W.commit conn + return e_a + +-- | The same @query@ methods can be used within a @Transaction@. +-- Nested @Transactions@ are implemented using savepoints. +instance SqlQuery Transaction where + query (q, p) = Transaction (ExceptT (ReaderT (\conn -> W.query conn q p))) + query_ (q, p) = Transaction (ExceptT (ReaderT (\conn -> W.query_ conn q p))) + +-- Transformer instances +-- These are all the same, except for the @withConnection@ definitions. + +instance SQL m => SQL (ExceptT e m) where + withConnection f = ExceptT (withConnection (runExceptT . f)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q + +instance {-# OVERLAPPABLE #-} SQL m => SQL (ReaderT r m) where + withConnection f = ReaderT (\r -> withConnection (\conn -> runReaderT (f conn) r)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q + +instance SQL m => SQL (MaybeT m) where + withConnection f = MaybeT (withConnection (runMaybeT . f)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q + +instance SQL m => SQL (SL.StateT s m) where + withConnection f = SL.StateT (\s -> withConnection (\conn -> SL.runStateT (f conn) s)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q + +instance SQL m => SQL (SS.StateT s m) where + withConnection f = SS.StateT (\s -> withConnection (\conn -> SS.runStateT (f conn) s)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q + +instance (Monoid w, SQL m) => SQL (S.RWST r w s m) where + withConnection f = S.RWST (\r s -> withConnection (\conn -> S.runRWST (f conn) r s)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q + +instance (Monoid w, SQL m) => SQL (L.RWST r w s m) where + withConnection f = L.RWST (\r s -> withConnection (\conn -> L.runRWST (f conn) r s)) + runTransaction' level t = lift $ runTransaction' level t + queryOn conn qp = lift $ queryOn conn qp + queryOn_ conn q = lift $ queryOn_ conn q diff --git a/src/Preql/Effect/Internal.hs b/src/Preql/Effect/Internal.hs --- a/src/Preql/Effect/Internal.hs +++ b/src/Preql/Effect/Internal.hs @@ -1,90 +1,17 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | We use IO in the representation of Transaction, but we don't want to allow arbitrary IO, only -- SQL queries. So keep it private. --- --- The SQL class refers to Transaction, and the Transaction instance refers to the class, so it all --- needs to be here. module Preql.Effect.Internal where -import Preql.Imports import Preql.Wire -import Preql.Wire.Internal -import Control.Exception (throwIO) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) import Database.PostgreSQL.LibPQ (Connection) -import qualified Preql.Wire.Query as W - --- | An Effect class for running SQL queries. You can think of this as a context --- specifying a particular Postgres connection (or connection pool). A minimal instance --- defines @runTransaction@. A typical instance will use 'runTransactionIO' or functions --- in 'Preql.Wire.Query' and log & rethrow errors. -class Monad m => SQL (m :: * -> *) where - -- | Run a parameterized query that returns data. The tuple argument is typically provided by - -- the 'sql' Quasiquoter. - query :: (ToSql p, FromSql r) => (Query, p) -> m (Vector r) - query = runTransaction . query - - -- | Run a parameterized query that does not return data. - query_ :: ToSql p => (Query, p) -> m () - query_ = runTransaction . query_ - - -- | Run multiple queries in a transaction. - runTransaction :: Transaction a -> m a - -- TODO add variant with isolation level - --- | Most larger applications will define an instance; this one is suitable to test out the library. -instance SQL (ReaderT Connection IO) where - runTransaction t = do - conn <- ask - lift (either throwIO pure =<< runTransactionIO t conn) - --- | Lift through any monad transformer without a more specific instance. -instance {-# OVERLAPPABLE #-} (MonadTrans t, Monad (t m), SQL m) => SQL (t m) where - query = lift . query - query_ = lift . query_ - runTransaction = lift . runTransaction - --- * Transactions - -- | A Transaction can only contain SQL queries (and pure functions). newtype Transaction a = Transaction (ExceptT QueryError (ReaderT Connection IO) a) deriving newtype (Functor, Applicative, Monad) - --- | Run the provided 'Transaction'. If it fails with a 'QueryError', roll back. -runTransactionIO :: Transaction a -> Connection -> IO (Either QueryError a) -runTransactionIO (Transaction m) conn = do - void $ W.query_ conn (Query "BEGIN TRANSACTION") () - e_a <- runReaderT (runExceptT m) conn - void $ case e_a of - Left _ -> W.query_ conn (Query "ROLLBACK") () - Right _ -> W.query_ conn (Query "COMMIT") () - return e_a - --- | The same @query@ methods can be used within a @Transaction@. --- Nested @Transactions@ are implemented using savepoints. -instance SQL Transaction where - query (q, p) = Transaction (ExceptT (ReaderT (\conn -> W.query conn q p))) - query_ (q, p) = Transaction (ExceptT (ReaderT (\conn -> W.query_ conn q p))) - runTransaction (Transaction t) = do - query_ (Query "SAVEPOINT preql_savepoint", ()) - Transaction . ExceptT . ReaderT $ \conn -> do - e_a <- runReaderT (runExceptT t) conn - case e_a of - Right _ -> void $ W.query_ conn (Query "RELEASE SAVEPOINT preql_savepoint") () - Left _ -> do - void $ W.query_ conn (Query "ROLLBACK SAVEPOINT preql_savepoint") () - -- release after rollback, so a later rolback catches the outer same-named savepoint - void $ W.query_ conn (Query "RELEASE SAVEPOINT preql_savepoint") () - return e_a diff --git a/src/Preql/QuasiQuoter/Raw/TH.hs b/src/Preql/QuasiQuoter/Raw/TH.hs --- a/src/Preql/QuasiQuoter/Raw/TH.hs +++ b/src/Preql/QuasiQuoter/Raw/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} @@ -60,22 +61,22 @@ query <- makeQuery rewritten case positionalCount of 0 -> -- only antiquotes (or no params) - return $ TupE [query, tupleOrSingle antiNames] + return $ tupleE [query, tupleOrSingle antiNames] 1 -> do -- one positional param, doesn't take a tuple patternName <- newName "c" return $ LamE [VarP patternName] - (TupE [query, tupleOrSingle (patternName : antiNames)]) + (tupleE [query, tupleOrSingle (patternName : antiNames)]) _ -> do -- at least two positional parameters patternNames <- cNames 'q' (fromIntegral positionalCount) return $ LamE [TupP (map VarP patternNames)] - (TupE [query, tupleOrSingle (patternNames ++ antiNames)]) + (tupleE [query, tupleOrSingle (patternNames ++ antiNames)]) Left err -> error err tupleOrSingle :: [Name] -> Exp tupleOrSingle names = case names of [name] -> VarE name - vs -> TupE $ map VarE vs + vs -> tupleE $ map VarE vs expressionOnly :: String -> (String -> Q Exp) -> QuasiQuoter expressionOnly name qq = QuasiQuoter @@ -104,3 +105,10 @@ in (unLex (NumberedParam newParam) : ss, name : ns) EOF -> go maxParam ts _ -> let (ss, ns) = go maxParam ts in (unLex token : ss, ns) + +tupleE :: [Exp] -> Exp +#if MIN_VERSION_template_haskell(2,16,0) +tupleE = TupE . fmap Just +#else +tupleE = TupE +#endif diff --git a/src/Preql/Wire.hs b/src/Preql/Wire.hs --- a/src/Preql/Wire.hs +++ b/src/Preql/Wire.hs @@ -16,3 +16,4 @@ import Preql.Wire.Internal as X (Query, RowDecoder) import Preql.Wire.ToSql as X import Preql.Wire.Types as X +import Preql.Wire.Query as X (IsolationLevel(..)) diff --git a/src/Preql/Wire/Errors.hs b/src/Preql/Wire/Errors.hs --- a/src/Preql/Wire/Errors.hs +++ b/src/Preql/Wire/Errors.hs @@ -27,8 +27,13 @@ instance Exception FieldError $(deriveJSON defaultOptions ''FieldError) +data PgType = Oid PQ.Oid -- ^ A Postgres type with a known ID + | TypeName Text -- ^ A Postgres type which we will need to lookup by name + deriving (Eq, Show, Typeable) +$(deriveJSON defaultOptions ''PgType) + data TypeMismatch = TypeMismatch - { expected :: PQ.Oid + { expected :: PgType , actual :: PQ.Oid , column :: Int , columnName :: Maybe Text diff --git a/src/Preql/Wire/FromSql.hs b/src/Preql/Wire/FromSql.hs --- a/src/Preql/Wire/FromSql.hs +++ b/src/Preql/Wire/FromSql.hs @@ -35,7 +35,7 @@ -- | A @FieldDecoder@ for a type @a@ consists of an OID indicating the -- Postgres type which can be decoded, and a parser from the binary -- representation of that type to the Haskell representation. -data FieldDecoder a = FieldDecoder PQ.Oid (BP.BinaryParser a) +data FieldDecoder a = FieldDecoder PgType (BP.BinaryParser a) deriving Functor throwLocated :: UnlocatedFieldError -> InternalDecoder a @@ -43,13 +43,14 @@ DecoderState{row = PQ.Row r, column = PQ.Col c} <- get throwError (FieldError (fromIntegral r) (fromIntegral c) failure) -decodeVector :: RowDecoder a -> PQ.Result -> IO (Either QueryError (Vector a)) -decodeVector rd@(RowDecoder oids _parsers) result = do - mismatches <- fmap catMaybes $ for (zip [0 ..] oids) $ \(column@(PQ.Col cint), expected) -> do - actual <- liftIO $ PQ.ftype result column - if actual == expected - then return Nothing - else do +decodeVector :: (PgType -> IO (Either QueryError PQ.Oid)) -> RowDecoder a -> PQ.Result -> IO (Either QueryError (Vector a)) +decodeVector lookupType rd@(RowDecoder pgtypes _parsers) result = do + mismatches <- fmap catMaybes $ for (zip [0 ..] pgtypes) $ \(column@(PQ.Col cint), expected) -> do + actual <- PQ.ftype result column + e_expectedOid <- lookupType expected + case e_expectedOid of + Right oid | actual == oid -> return Nothing + _ -> do m_name <- liftIO $ PQ.fname result column let columnName = decodeUtf8With lenientDecode <$> m_name return $ Just (TypeMismatch{column = fromIntegral cint, ..}) @@ -82,44 +83,44 @@ fromSql :: RowDecoder a instance FromSqlField Bool where - fromSqlField = FieldDecoder OID.boolOid PGB.bool + fromSqlField = FieldDecoder (Oid OID.boolOid) PGB.bool instance FromSql Bool where fromSql = notNull fromSqlField instance FromSqlField Int16 where - fromSqlField = FieldDecoder OID.int2Oid PGB.int + fromSqlField = FieldDecoder (Oid OID.int2Oid) PGB.int instance FromSql Int16 where fromSql = notNull fromSqlField instance FromSqlField Int32 where - fromSqlField = FieldDecoder OID.int4Oid PGB.int + fromSqlField = FieldDecoder (Oid OID.int4Oid) PGB.int instance FromSql Int32 where fromSql = notNull fromSqlField instance FromSqlField Int64 where - fromSqlField = FieldDecoder OID.int8Oid PGB.int + fromSqlField = FieldDecoder (Oid OID.int8Oid) PGB.int instance FromSql Int64 where fromSql = notNull fromSqlField instance FromSqlField Float where - fromSqlField = FieldDecoder OID.float4Oid PGB.float4 + fromSqlField = FieldDecoder (Oid OID.float4Oid) PGB.float4 instance FromSql Float where fromSql = notNull fromSqlField instance FromSqlField Double where - fromSqlField = FieldDecoder OID.float8Oid PGB.float8 + fromSqlField = FieldDecoder (Oid OID.float8Oid) PGB.float8 instance FromSql Double where fromSql = notNull fromSqlField -- TODO does Postgres have a single-char type? Does it always return bpchar? -- instance FromSqlField Char where --- fromSqlField = FieldDecoder OID.charOid PGB.char +-- fromSqlField = FieldDecoder (Oid OID.charOid) PGB.char -- instance FromSql Char where fromSql = notNull fromSqlField instance FromSqlField String where - fromSqlField = FieldDecoder OID.textOid (T.unpack <$> PGB.text_strict) + fromSqlField = FieldDecoder (Oid OID.textOid) (T.unpack <$> PGB.text_strict) instance FromSql String where fromSql = notNull fromSqlField instance FromSqlField Text where - fromSqlField = FieldDecoder OID.textOid PGB.text_strict + fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_strict instance FromSql Text where fromSql = notNull fromSqlField instance FromSqlField TL.Text where - fromSqlField = FieldDecoder OID.textOid PGB.text_lazy + fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_lazy instance FromSql TL.Text where fromSql = notNull fromSqlField -- | If you want to encode some more specific Haskell type via JSON, @@ -127,43 +128,47 @@ -- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this -- instance. instance FromSqlField ByteString where - fromSqlField = FieldDecoder OID.byteaOid (BS.copy <$> BP.remainders) + fromSqlField = FieldDecoder (Oid OID.byteaOid) (BS.copy <$> BP.remainders) instance FromSql ByteString where fromSql = notNull fromSqlField instance FromSqlField BSL.ByteString where - fromSqlField = FieldDecoder OID.byteaOid (BSL.fromStrict . BS.copy <$> BP.remainders) + fromSqlField = FieldDecoder (Oid OID.byteaOid) (BSL.fromStrict . BS.copy <$> BP.remainders) instance FromSql BSL.ByteString where fromSql = notNull fromSqlField -- TODO check for integer_datetimes setting instance FromSqlField UTCTime where - fromSqlField = FieldDecoder OID.timestamptzOid PGB.timestamptz_int + fromSqlField = FieldDecoder (Oid OID.timestamptzOid) PGB.timestamptz_int instance FromSql UTCTime where fromSql = notNull fromSqlField instance FromSqlField Day where - fromSqlField = FieldDecoder OID.dateOid PGB.date + fromSqlField = FieldDecoder (Oid OID.dateOid) PGB.date instance FromSql Day where fromSql = notNull fromSqlField instance FromSqlField TimeOfDay where - fromSqlField = FieldDecoder OID.timeOid PGB.time_int + fromSqlField = FieldDecoder (Oid OID.timeOid) PGB.time_int instance FromSql TimeOfDay where fromSql = notNull fromSqlField instance FromSqlField TimeTZ where - fromSqlField = FieldDecoder OID.timetzOid (uncurry TimeTZ <$> PGB.timetz_int) + fromSqlField = FieldDecoder (Oid OID.timetzOid) (uncurry TimeTZ <$> PGB.timetz_int) instance FromSql TimeTZ where fromSql = notNull fromSqlField instance FromSqlField UUID where - fromSqlField = FieldDecoder OID.uuidOid PGB.uuid + fromSqlField = FieldDecoder (Oid OID.uuidOid) PGB.uuid instance FromSql UUID where fromSql = notNull fromSqlField +instance FromSqlField PQ.Oid where + fromSqlField = PQ.Oid <$> FieldDecoder (Oid OID.oidOid) PGB.int +instance FromSql PQ.Oid where fromSql = notNull fromSqlField + -- | If you want to encode some more specific Haskell type via JSON, -- it is more efficient to use 'fromSqlJsonField' rather than this -- instance. instance FromSqlField JSON.Value where - fromSqlField = FieldDecoder OID.jsonbOid PGB.jsonb_ast + fromSqlField = FieldDecoder (Oid OID.jsonbOid) PGB.jsonb_ast instance FromSql JSON.Value where fromSql = notNull fromSqlField fromSqlJsonField :: JSON.FromJSON a => FieldDecoder a -fromSqlJsonField = FieldDecoder OID.jsonbOid +fromSqlJsonField = FieldDecoder (Oid OID.jsonbOid) (PGB.jsonb_bytes (first T.pack . JSON.eitherDecode . BSL.fromStrict)) -- Overlappable so applications can write Maybe for multi-field domain types diff --git a/src/Preql/Wire/Internal.hs b/src/Preql/Wire/Internal.hs --- a/src/Preql/Wire/Internal.hs +++ b/src/Preql/Wire/Internal.hs @@ -25,11 +25,10 @@ newtype Query = Query ByteString deriving (Show, IsString) --- TODO PgType for non-builtin types -- | @RowDecoder@ is 'Applicative' but not 'Monad' so that we can -- assemble all of the OIDs before we read any of the field data sent --- by Postgresj. -data RowDecoder a = RowDecoder [PQ.Oid] (InternalDecoder a) +-- by Postgres. +data RowDecoder a = RowDecoder [PgType] (InternalDecoder a) deriving Functor instance Applicative RowDecoder where @@ -37,6 +36,9 @@ RowDecoder t1 p1 <*> RowDecoder t2 p2 = RowDecoder (t1 <> t2) (p1 <*> p2) -- TODO can I use ValidationT instead of ExceptT, since I ensure Column is incremented before errors? +-- | Internal because we need IO for the libpq FFI, but we promise not +-- to do any IO besides decoding. We don't even make network calls to +-- Postgres in @InternalDecoder@ type InternalDecoder = StateT DecoderState (ExceptT FieldError IO) data DecoderState = DecoderState diff --git a/src/Preql/Wire/Query.hs b/src/Preql/Wire/Query.hs --- a/src/Preql/Wire/Query.hs +++ b/src/Preql/Wire/Query.hs @@ -9,6 +9,7 @@ import Preql.Imports import qualified Data.Text as T +import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ queryWith :: RowEncoder p -> RowDecoder r -> PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r)) @@ -18,7 +19,7 @@ e_result <- execParams enc conn query params case e_result of Left err -> return (Left err) - Right result -> decodeVector dec result + Right result -> decodeVector (lookupType conn) dec result -- If there is no result, we don't need a Decoder queryWith_ :: RowEncoder p -> PQ.Connection -> Query -> p -> IO (Either QueryError ()) @@ -53,3 +54,31 @@ case m_msg of Just msg -> return (Left (decodeUtf8With lenientDecode msg)) Nothing -> return (Left "No error message available") + +lookupType :: PQ.Connection -> PgType -> IO (Either QueryError PQ.Oid) +lookupType _ (Oid oid) = return (Right oid) +lookupType conn (TypeName name) = do + e_rows <- query conn "SELECT oid FROM pg_type WHERE typname = $1" name + case fmap (V.!? 0) e_rows of + Left e -> return (Left e) + Right (Just oid) -> return (Right oid) + Right Nothing -> return (Left (ConnectionError ("No oid for: " <> name))) + +data IsolationLevel + = ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +begin :: PQ.Connection -> IsolationLevel -> IO (Either QueryError ()) +begin conn level = query_ conn q () where + q = case level of + ReadCommitted -> "BEGIN ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> "BEGIN ISOLATION LEVEL REPEATABLE READ" + Serializable -> "BEGIN ISOLATION LEVEL SERIALIZABLE" + +commit :: PQ.Connection -> IO (Either QueryError ()) +commit conn = query_ conn "COMMIT" () + +rollback :: PQ.Connection -> IO (Either QueryError ()) +rollback conn = query_ conn "ROLLBACK" () diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs --- a/test/Test/Wire.hs +++ b/test/Test/Wire.hs @@ -1,15 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Test.Wire where -import Preql.Effect -import Preql.QuasiQuoter.Raw.TH (sql) import Preql.Wire +import Test.Wire.Enum import Control.Exception (Exception, bracket_, throwIO) import Control.Monad @@ -18,10 +16,11 @@ import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text) -import Data.Time (Day, TimeOfDay, UTCTime, TimeZone) #if MIN_VERSION_time(1,9,0) +import Data.Time (Day, TimeOfDay, UTCTime) import Data.Time.Format.ISO8601 (iso8601ParseM) #else +import Data.Time (Day, TimeOfDay, UTCTime, TimeZone) import Data.Time.Format (parseTimeM, defaultTimeLocale, iso8601DateFormat, ParseTime) #endif import Data.Text.Encoding (encodeUtf8) @@ -174,6 +173,19 @@ query_ "INSERT INTO encoder_tests (b, i16, i32, i64) VALUES ($1, $2, $3, $4)" v assertQuery [v] "SELECT b, i16, i32, i64 FROM encoder_tests" ] + + , testGroup "user-defined types" + [ inTransaction "decode enum" $ do + query_ "drop type if exists my_enum" () + query_ "create type my_enum as enum ('A', 'B', 'C')" () + assertQuery [A] "select 'A'::my_enum" + , inTransaction "type mismatch error" $ do + mismatch <- query @() @MyEnum "select 'A'" () + case mismatch of + Left (PgTypeMismatch + [TypeMismatch { expected = TypeName "my_enum", column = 0 }]) -> pure () + _ -> assertFailure "did not get expected TypeMismatch error" + ] ] initDB :: HasCallStack => IO PQ.Connection diff --git a/test/Test/Wire/Enum.hs b/test/Test/Wire/Enum.hs new file mode 100644 --- /dev/null +++ b/test/Test/Wire/Enum.hs @@ -0,0 +1,21 @@ +-- | An Enum type to test Postgres typname lookup. + +module Test.Wire.Enum where + +import Preql.Wire + +import Text.Read (readMaybe) +import qualified BinaryParser as BP +import qualified Data.Text as T +import qualified PostgreSQL.Binary.Decoding as PGB + +data MyEnum = A | B | C + deriving (Show, Read, Eq, Ord, Bounded, Enum) + +instance FromSqlField MyEnum where + fromSqlField = FieldDecoder (TypeName "my_enum") $ do + text <- PGB.text_strict + case readMaybe (T.unpack text) of + Just x -> return x + Nothing -> BP.failure ("could not parse as MyEnum: " <> text) +instance FromSql MyEnum where fromSql = notNull fromSqlField