preql 0.2 → 0.3

raw patch · 12 files changed

+399/−222 lines, 12 filesdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base, bytestring, postgresql-libpq, tasty, tasty-hunit, template-haskell, text, uuid, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• preql.cabal +118/−104
• src/Preql/Effect.hs +143/−2
• src/Preql/Effect/Internal.hs +3/−76
• src/Preql/QuasiQuoter/Raw/TH.hs +12/−4
• src/Preql/Wire.hs +1/−0
• src/Preql/Wire/Errors.hs +6/−1
• src/Preql/Wire/FromSql.hs +32/−27
• src/Preql/Wire/Internal.hs +5/−3
• src/Preql/Wire/Query.hs +30/−1
• test/Test/Wire.hs +16/−4
• test/Test/Wire/Enum.hs +21/−0

@@ -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:

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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(..))

@@ -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

@@ -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

@@ -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

@@ -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" ()

@@ -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

@@ -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