preql 0.1 → 0.2
raw patch · 23 files changed
+2635/−314 lines, 23 filesdep +preqldep +scientificdep +tastydep −postgresql-simpledep −sybdep ~aesondep ~arraydep ~base
Dependencies added: preql, scientific, tasty, tasty-hunit
Dependencies removed: postgresql-simple, syb
Dependency ranges changed: aeson, array, base, bytestring, bytestring-strict-builder, contravariant, free, postgresql-binary, postgresql-libpq, template-haskell, text, th-lift-instances, time, transformers, uuid, vector
Files
- CHANGELOG.md +7/−0
- LICENSE +1/−0
- preql.cabal +75/−22
- src/Preql.hs +18/−4
- src/Preql/Effect.hs +3/−45
- src/Preql/Effect/Internal.hs +90/−0
- src/Preql/Imports.hs +1/−1
- src/Preql/PQResultUtils.hs +0/−115
- src/Preql/QuasiQuoter/Raw/TH.hs +19/−0
- src/Preql/Wire.hs +12/−2
- src/Preql/Wire/Connection.hs +0/−8
- src/Preql/Wire/Errors.hs +44/−0
- src/Preql/Wire/FromSql.hs +64/−50
- src/Preql/Wire/Internal.hs +16/−19
- src/Preql/Wire/Orphans.hs +21/−0
- src/Preql/Wire/Query.hs +32/−28
- src/Preql/Wire/ToSql.hs +47/−20
- src/Preql/Wire/Tuples.hs +44/−0
- src/Preql/Wire/TypeInfo/Static.hs +1797/−0
- src/Preql/Wire/TypeInfo/Types.hs +52/−0
- src/Preql/Wire/Types.hs +1/−0
- test/Test.hs +65/−0
- test/Test/Wire.hs +226/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# 0.1 (2020-02-29)++0.1 highlights include:++- binary wire format+- check that Postgres sent expected type before decoding+- Quasiquoter supports mixing numbered & antiquoted params
LICENSE view
@@ -1,4 +1,5 @@ Copyright (c) 2019, Daniel Bergey+Copyright (c) 2011, Leon P Smith All rights reserved.
preql.cabal view
@@ -1,14 +1,30 @@-cabal-version: 1.12+cabal-version: 1.18 name: preql-version: 0.1+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: experiments with SQL+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 source-repository head type: git@@ -18,16 +34,20 @@ exposed-modules: Preql Preql.Effect+ Preql.Effect.Internal Preql.Imports- Preql.PQResultUtils Preql.QuasiQuoter.Raw.Lex Preql.QuasiQuoter.Raw.TH Preql.Wire- Preql.Wire.Connection+ 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@@ -36,23 +56,56 @@ default-language: Haskell2010 default-extensions: OverloadedStrings build-depends:- aeson >=1.4.6.0 && <1.5,- array >=0.5.4.0 && <0.6,- base >=4.13.0.0 && <4.14,+ 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.10.0 && <0.11,- bytestring-strict-builder >=0.4.5.3 && <0.5,- contravariant >=1.5.2 && <1.6,- free >=5.1.3 && <5.2,+ 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.2 && <0.13,- postgresql-libpq >=0.9.4.2 && <0.10,- postgresql-simple >=0.6.2 && <0.7,- syb >=0.7.1 && <0.8,- template-haskell >=2.15.0.0 && <2.16,- text >=1.2.4.0 && <1.3,- th-lift-instances >=0.1.14 && <0.2,- time >=1.9.3 && <1.10,- transformers >=0.5.6.2 && <0.6,+ 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.1.2 && <0.13+ vector >=0.12.0 && <0.13++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
src/Preql.hs view
@@ -1,5 +1,19 @@-module Preql (module X) where+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+module Preql (+ SQL(..), sql+ , Transaction, Query+ -- * functions for writing SQL instances+ , runTransactionIO+ -- * Decoding rows+ , FromSql, FromSqlField+ -- * Encoding parameters+ , ToSql, ToSqlField+ -- * Errors+ , QueryError(..), FieldError(..), UnlocatedFieldError(..), TypeMismatch(..)+ -- | encoding & decoding to wire format+ , module Preql.Wire+ ) where -import Preql.Wire as X-import Preql.QuasiQuoter.Raw.TH as X (sql)-import Preql.Effect as X+import Preql.Wire+import Preql.QuasiQuoter.Raw.TH (sql)+import Preql.Effect
src/Preql/Effect.hs view
@@ -1,50 +1,8 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DefaultSignatures #-} -- | SQL Effect class, basically capturing some way of accessing a database. module Preql.Effect- ( Query, SQL(..)+ ( Query, SQL(..), Transaction, runTransactionIO ) where -import Preql.Wire--import Control.Exception (throwIO)-import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Except (ExceptT)-import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.Trans.Reader (ReaderT, ask)-import Control.Monad.Trans.State (StateT)-import Control.Monad.Trans.Writer (WriterT)-import Data.Vector (Vector)-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).-class Monad m => SQL (m :: * -> *) where- query :: (ToSql p, FromSql r) => (Query, p) -> m (Vector r)- query_ :: ToSql p => (Query, p) -> m ()-- default query :: (MonadTrans t, SQL m', m ~ t m', ToSql p, FromSql r) => (Query, p) -> m (Vector r)- query qp = lift (query qp)-- default query_ :: (MonadTrans t, SQL m', m ~ t m', ToSql p) => (Query, p) -> m ()- query_ qp = lift (query_ qp)---- | Most larger applications will define an instance; this one is suitable to test out the library.-instance SQL (ReaderT Connection IO) where- query (q, p) = do- conn <- ask- lift (either throwIO pure =<< W.query conn q p)- query_ (q, p) = do- conn <- ask- lift (either throwIO pure =<< W.query_ conn q p)--instance SQL m => SQL (ExceptT e m)-instance SQL m => SQL (MaybeT m)-instance SQL m => SQL (StateT s m)-instance (Monoid w, SQL m) => SQL (WriterT w m)-instance {-# OVERLAPPABLE #-} SQL m => SQL (ReaderT r m)+import Preql.Effect.Internal+import Preql.Wire.Internal
+ src/Preql/Effect/Internal.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}++-- | 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 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
src/Preql/Imports.hs view
@@ -14,7 +14,7 @@ import Data.Bifunctor as X import Data.ByteString (ByteString) import Data.Functor as X-import Data.Maybe as X (catMaybes)+import Data.Maybe as X (catMaybes, fromMaybe) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)
− src/Preql/PQResultUtils.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | taken verbatim from Database.PostgreSQL.Simple.Internal.PQResultUtils--module Preql.PQResultUtils where--import Control.Exception as E-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Strict-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.Foldable (for_)-import qualified Data.Vector as V-import qualified Data.Vector.Mutable as MV-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector.Unboxed.Mutable as MVU-import qualified Database.PostgreSQL.LibPQ as PQ-import Database.PostgreSQL.Simple.FromField (ResultError (..))-import Database.PostgreSQL.Simple.Internal as Base hiding (result,- row)-import Database.PostgreSQL.Simple.Ok-import Database.PostgreSQL.Simple.TypeInfo-import Database.PostgreSQL.Simple.Types (Query (..))--finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]-finishQueryWith parser conn q result = finishQueryWith' q result $ do- nrows <- PQ.ntuples result- ncols <- PQ.nfields result- forM' 0 (nrows-1) $ \row ->- getRowWith parser row ncols conn result--finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)-finishQueryWithV parser conn q result = finishQueryWith' q result $ do- nrows <- PQ.ntuples result- let PQ.Row nrows' = nrows- ncols <- PQ.nfields result- mv <- MV.unsafeNew (fromIntegral nrows')- for_ [ 0 .. nrows-1 ] $ \row -> do- let PQ.Row row' = row- value <- getRowWith parser row ncols conn result- MV.unsafeWrite mv (fromIntegral row') value- V.unsafeFreeze mv--finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)-finishQueryWithVU parser conn q result = finishQueryWith' q result $ do- nrows <- PQ.ntuples result- let PQ.Row nrows' = nrows- ncols <- PQ.nfields result- mv <- MVU.unsafeNew (fromIntegral nrows')- for_ [ 0 .. nrows-1 ] $ \row -> do- let PQ.Row row' = row- value <- getRowWith parser row ncols conn result- MVU.unsafeWrite mv (fromIntegral row') value- VU.unsafeFreeze mv--finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a-finishQueryWith' q result k = do- status <- PQ.resultStatus result- case status of- PQ.TuplesOk -> k- PQ.EmptyQuery -> queryErr "query: Empty query"- PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)"- PQ.CopyOut -> queryErr "query: COPY TO is not supported"- PQ.CopyIn -> queryErr "query: COPY FROM is not supported"-#if MIN_VERSION_postgresql_libpq(0,9,3)- PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"-#endif-#if MIN_VERSION_postgresql_libpq(0,9,2)- PQ.SingleTuple -> queryErr "query: single-row mode is not supported"-#endif- PQ.BadResponse -> throwResultError "query" result status- PQ.NonfatalError -> throwResultError "query" result status- PQ.FatalError -> throwResultError "query" result status- where- queryErr msg = throwIO $ QueryError msg q--getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r-getRowWith parser row ncols conn result = do- let rw = Row row result- let unCol (PQ.Col x) = fromIntegral x :: Int- okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn- case okvc of- Ok (val,col) | col == ncols -> return val- | otherwise -> do- vals <- forM' 0 (ncols-1) $ \c -> do- tinfo <- getTypeInfo conn =<< PQ.ftype result c- v <- PQ.getvalue result row c- return ( tinfo- , fmap ellipsis v )- throw (ConversionFailed- (show (unCol ncols) ++ " values: " ++ show vals)- Nothing- ""- (show (unCol col) ++ " slots in target type")- "mismatch between number of columns to convert and number in target type")- Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"- Errors [x] -> throwIO x- Errors xs -> throwIO $ ManyErrors xs--ellipsis :: ByteString -> ByteString-ellipsis bs- | B.length bs > 15 = B.take 10 bs `B.append` "[...]"- | otherwise = bs--forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]-forM' lo hi m = loop hi []- where- loop !n !as- | n < lo = return as- | otherwise = do- a <- m n- loop (n-1) (a:as)-{-# INLINE forM' #-}
src/Preql/QuasiQuoter/Raw/TH.hs view
@@ -27,6 +27,25 @@ -- | Given a SQL query with ${} antiquotes, splice a pair @(Query -- p r, p)@ or a function @\p' -> (Query p r, p)@ if the SQL -- string includes both antiquote and positional parameters.++-- | The @sql@ Quasiquoter allows passing parameters to a query by name, inside a @${}@ antiquote. For example:+-- @[sql| SELECT name, age FROM cats WHERE age >= ${minAge} and age < ${maxAge} |]@+-- The Haskell term within @{}@ must be a variable in scope; more complex expressions are not supported.+--+-- Antiquotes are replaced by positional (@$1, $2@) parameters supported by Postgres, and the+-- encoded values are sent with @PexecParams@+--+-- Mixed named & numbered parameters are also supported. It is hoped that this will be useful when+-- migrating existing queries. For example:+-- @query $ [sql| SELECT name, age FROM cats WHERE age >= ${minAge} and age < $1 |] maxAge@+-- Named parameters will be assigned numbers higher than the highest numbered paramater placeholder.+--+-- A quote with only named parameters is converted to a tuple '(Query, p)'. For example:+-- @("SELECT name, age FROM cats WHERE age >= $1 and age < $2", (minAge, maxAge))@+-- If there are no parameters, the inner tuple is @()@, like @("SELECT * FROM cats", ())@.+-- If there are both named & numbered params, the splice is a function taking a tuple and returning+-- @(Query, p)@ where p includes both named & numbered params. For example:+-- @\a -> ("SELECT name, age FROM cats WHERE age >= $1 and age < $2", (a, maxAge))@ sql :: QuasiQuoter sql = expressionOnly "aritySql " $ \raw -> do loc <- location
src/Preql/Wire.hs view
@@ -1,8 +1,18 @@+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+ -- | This module re-exports definitions from Wire.* that are expected to be useful -module Preql.Wire (module X) where+module Preql.Wire (+ -- * Decoding rows+ FromSql, FromSqlField+ -- * Encoding parameters+ , ToSql, ToSqlField+ -- * Errors+ , QueryError(..), FieldError(..), UnlocatedFieldError(..), TypeMismatch(..)+ , module X) where import Preql.Wire.FromSql as X-import Preql.Wire.Internal as X (Query, RowDecoder, DecoderState(..), LocatedError(..), FieldError(..))+import Preql.Wire.Errors as X+import Preql.Wire.Internal as X (Query, RowDecoder) import Preql.Wire.ToSql as X import Preql.Wire.Types as X
− src/Preql/Wire/Connection.hs
@@ -1,8 +0,0 @@--- | For now, re-export Connection code from postgresql-simple--module Preql.Wire.Connection- ( Connection(..), ConnectInfo(..), defaultConnectInfo- , connect, connectPostgreSQL- ) where--import Database.PostgreSQL.Simple.Internal
+ src/Preql/Wire/Errors.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Errors raised by functions in Preql.Wire++module Preql.Wire.Errors where++import Preql.Imports+import Preql.Wire.Orphans ()++import Data.Aeson.TH (defaultOptions, deriveJSON)++import qualified Database.PostgreSQL.LibPQ as PQ++-- | Errors that can occur in decoding a single field.+data UnlocatedFieldError+ = UnexpectedNull+ | ParseFailure Text+ deriving (Eq, Show, Typeable)+$(deriveJSON defaultOptions ''UnlocatedFieldError)++-- | A decoding error with information about the row & column of the result where it+-- occured.+data FieldError = FieldError+ { errorRow :: Int+ , errorColumn :: Int+ , failure :: UnlocatedFieldError+ } deriving (Eq, Show, Typeable)+instance Exception FieldError+$(deriveJSON defaultOptions ''FieldError)++data TypeMismatch = TypeMismatch+ { expected :: PQ.Oid+ , actual :: PQ.Oid+ , column :: Int+ , columnName :: Maybe Text+ } deriving (Eq, Show, Typeable)+$(deriveJSON defaultOptions ''TypeMismatch)++data QueryError+ = ConnectionError Text+ | DecoderError FieldError+ | PgTypeMismatch [TypeMismatch]+ deriving (Eq, Show, Typeable)+instance Exception QueryError+$(deriveJSON defaultOptions ''QueryError)
src/Preql/Wire/FromSql.hs view
@@ -1,27 +1,25 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# HLINT ignore "Use camelCase" #-}- {-# LANGUAGE DeriveFunctor #-}+ -- | Decoding values from Postgres wire format to Haskell. module Preql.Wire.FromSql where -import Preql.Wire.Internal-import Preql.Wire.Types+import Preql.Wire.Errors+import Preql.Wire.Internal+import Preql.Wire.Tuples (deriveFromSqlTuple)+import Preql.Wire.Types -import Control.Applicative.Free-import Control.Monad.Except-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.State-import Data.Int-import Data.Time (Day, TimeOfDay, UTCTime)-import Data.UUID (UUID)-import Preql.Imports+import Control.Monad.Except+import Control.Monad.Trans.State+import Data.Int+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.UUID (UUID)+import Preql.Imports import qualified BinaryParser as BP import qualified Data.Aeson as JSON@@ -31,43 +29,37 @@ import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ-import qualified Database.PostgreSQL.Simple.TypeInfo.Static as OID import qualified PostgreSQL.Binary.Decoding as PGB+import qualified Preql.Wire.TypeInfo.Static as OID +-- | 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) deriving Functor -data DecoderError = FieldError (LocatedError FieldError) | PgTypeMismatch [TypeMismatch]- deriving (Show, Eq, Typeable)-instance Exception DecoderError--data TypeMismatch = TypeMismatch- { expected :: PQ.Oid- , actual :: PQ.Oid- , column :: PQ.Column- , columnName :: Maybe Text- } deriving (Eq, Show, Typeable)--throwLocated :: FieldError -> InternalDecoder a+throwLocated :: UnlocatedFieldError -> InternalDecoder a throwLocated failure = do- DecoderState{..} <- get- throwError (LocatedError row column failure)+ DecoderState{row = PQ.Row r, column = PQ.Col c} <- get+ throwError (FieldError (fromIntegral r) (fromIntegral c) failure) -decodeVector :: RowDecoder a -> PQ.Result -> ExceptT DecoderError IO (Vector a)-decodeVector rd@(RowDecoder oids parsers) result = do- mismatches <- fmap catMaybes $ for (zip [PQ.Col 0 ..] oids) $ \(column, expected) -> do+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 m_name <- liftIO $ PQ.fname result column let columnName = decodeUtf8With lenientDecode <$> m_name- return $ Just (TypeMismatch{..})- unless (null mismatches) (throwError (PgTypeMismatch mismatches))- (PQ.Row ntuples) <- liftIO $ PQ.ntuples result- let toRow = PQ.toRow . fromIntegral- withExceptT FieldError $- V.generateM (fromIntegral ntuples) (decodeRow rd result . toRow)+ return $ Just (TypeMismatch{column = fromIntegral cint, ..})+ if not (null mismatches)+ then return (Left (PgTypeMismatch mismatches))+ else do+ (PQ.Row ntuples) <- liftIO $ PQ.ntuples result+ let toRow = PQ.toRow . fromIntegral+ fmap (first DecoderError) . runExceptT $+ V.generateM (fromIntegral ntuples) (decodeRow rd result . toRow) notNull :: FieldDecoder a -> RowDecoder a notNull (FieldDecoder oid parser) = RowDecoder [oid] $ do@@ -113,9 +105,10 @@ fromSqlField = FieldDecoder OID.float8Oid PGB.float8 instance FromSql Double where fromSql = notNull fromSqlField -instance FromSqlField Char where- fromSqlField = FieldDecoder OID.charOid PGB.char-instance FromSql Char 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+-- instance FromSql Char where fromSql = notNull fromSqlField instance FromSqlField String where fromSqlField = FieldDecoder OID.textOid (T.unpack <$> PGB.text_strict)@@ -163,13 +156,16 @@ instance FromSql UUID where fromSql = notNull fromSqlField -- | If you want to encode some more specific Haskell type via JSON,--- it is more efficient to use 'Data.Aeson.encode' and--- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- it is more efficient to use 'fromSqlJsonField' rather than this -- instance. instance FromSqlField JSON.Value where fromSqlField = FieldDecoder OID.jsonbOid PGB.jsonb_ast instance FromSql JSON.Value where fromSql = notNull fromSqlField +fromSqlJsonField :: JSON.FromJSON a => FieldDecoder a+fromSqlJsonField = FieldDecoder OID.jsonbOid+ (PGB.jsonb_bytes (first T.pack . JSON.eitherDecode . BSL.fromStrict))+ -- Overlappable so applications can write Maybe for multi-field domain types instance {-# OVERLAPPABLE #-} FromSqlField a => FromSql (Maybe a) where fromSql = nullable fromSqlField@@ -180,11 +176,29 @@ instance (FromSql a, FromSql b, FromSql c) => FromSql (a, b, c) where fromSql = (,,) <$> fromSql <*> fromSql <*> fromSql -instance (FromSql a, FromSql b, FromSql c, FromSql d) => FromSql (a, b, c, d) where- fromSql = (,,,) <$> fromSql <*> fromSql <*> fromSql <*> fromSql--instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e) => FromSql (a, b, c, d, e) where- fromSql = (,,,,) <$> fromSql <*> fromSql <*> fromSql <*> fromSql <*> fromSql+-- The instances below all follow the pattern laid out by the tuple+-- instances above. The ones above are written out without the macro+-- to illustrate the pattern. --- -- TODO more tuple instances--- -- TODO TH to make this less tedious+$(deriveFromSqlTuple 4)+$(deriveFromSqlTuple 5)+$(deriveFromSqlTuple 6)+$(deriveFromSqlTuple 7)+$(deriveFromSqlTuple 8)+$(deriveFromSqlTuple 9)+$(deriveFromSqlTuple 10)+$(deriveFromSqlTuple 11)+$(deriveFromSqlTuple 12)+$(deriveFromSqlTuple 13)+$(deriveFromSqlTuple 14)+$(deriveFromSqlTuple 15)+$(deriveFromSqlTuple 16)+$(deriveFromSqlTuple 17)+$(deriveFromSqlTuple 18)+$(deriveFromSqlTuple 19)+$(deriveFromSqlTuple 20)+$(deriveFromSqlTuple 21)+$(deriveFromSqlTuple 22)+$(deriveFromSqlTuple 23)+$(deriveFromSqlTuple 24)+$(deriveFromSqlTuple 25)
src/Preql/Wire/Internal.hs view
@@ -1,15 +1,21 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | +-- | The types in this module have invariants which cannot be checked+-- if their constructors are in scope. Preql.Wire exports the type+-- names only.+ module Preql.Wire.Internal where -import Control.Monad.Trans.Except-import Control.Monad.Trans.State-import Data.String (IsString)-import Preql.Imports+import Preql.Wire.Errors +import Control.Monad.Trans.Except+import Control.Monad.Trans.State+import Data.String (IsString)+import Preql.Imports+ import qualified Database.PostgreSQL.LibPQ as PQ -- TODO less ambiguous name (or rename others)@@ -20,6 +26,9 @@ 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) deriving Functor @@ -28,7 +37,7 @@ 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?-type InternalDecoder = StateT DecoderState (ExceptT (LocatedError FieldError) IO)+type InternalDecoder = StateT DecoderState (ExceptT FieldError IO) data DecoderState = DecoderState { result :: PQ.Result@@ -36,19 +45,7 @@ , column :: PQ.Column } deriving (Show, Eq) -data LocatedError a = LocatedError- { errorRow :: PQ.Row- , errorColumn :: PQ.Column- , failure :: a- } deriving (Eq, Show, Typeable)-instance (Show a, Typeable a) => Exception (LocatedError a)--data FieldError- = UnexpectedNull- | ParseFailure Text- deriving (Eq, Show, Typeable)--decodeRow :: RowDecoder a -> PQ.Result -> PQ.Row -> ExceptT (LocatedError FieldError) IO a+decodeRow :: RowDecoder a -> PQ.Result -> PQ.Row -> ExceptT FieldError IO a decodeRow (RowDecoder _ parsers) result row = evalStateT parsers (DecoderState result row 0)
+ src/Preql/Wire/Orphans.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DerivingStrategies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Orphan instances++module Preql.Wire.Orphans where++import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), withScientific)+import Data.Scientific (toBoundedInteger)+import qualified Database.PostgreSQL.LibPQ as PQ++-- TODO use a locally-defined PgType, and hang instances on that, instead++instance ToJSON PQ.Oid where+ toJSON (PQ.Oid oid) = Number (fromIntegral oid)++instance FromJSON PQ.Oid where+ parseJSON = withScientific "Oid" $ \sci ->+ case toBoundedInteger sci of+ Just i -> return (PQ.Oid i)+ Nothing -> fail "expected integer Oid"
src/Preql/Wire/Query.hs view
@@ -1,36 +1,44 @@ module Preql.Wire.Query where -import Preql.Wire.FromSql-import Preql.Wire.Internal-import Preql.Wire.ToSql+import Preql.Wire.Errors+import Preql.Wire.FromSql+import Preql.Wire.Internal+import Preql.Wire.ToSql -import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.Trans.Except-import Preql.Imports+import Control.Monad+import Preql.Imports +import qualified Data.Text as T import qualified Database.PostgreSQL.LibPQ as PQ queryWith :: RowEncoder p -> RowDecoder r -> PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r))-queryWith enc dec conn (Query query) params = runExceptT $ do+queryWith enc dec conn (Query query) params = do -- TODO safer Connection type -- withMVar (connectionHandle conn) $ \connRaw -> do- result <- execParams enc conn query params- withExceptT DecoderError (decodeVector dec result)+ e_result <- execParams enc conn query params+ case e_result of+ Left err -> return (Left err)+ Right result -> decodeVector dec result -- If there is no result, we don't need a Decoder queryWith_ :: RowEncoder p -> PQ.Connection -> Query -> p -> IO (Either QueryError ())-queryWith_ enc conn (Query query) params =- runExceptT (void (execParams enc conn query params))+queryWith_ enc conn (Query query) params = do+ e_result <- execParams enc conn query params+ return (void e_result) -execParams :: RowEncoder p -> PQ.Connection -> ByteString -> p -> ExceptT QueryError IO PQ.Result+execParams :: RowEncoder p -> PQ.Connection -> ByteString -> p -> IO (Either QueryError PQ.Result) execParams enc conn query params = do- result <- queryError conn =<< liftIO (PQ.execParams conn query (runEncoder enc params) PQ.Binary)- status <- liftIO (PQ.resultStatus result)- unless (status == PQ.CommandOk || status == PQ.TuplesOk) $ do- msg <- liftIO (PQ.resStatus status)- throwE (QueryError (decodeUtf8With lenientDecode msg))- return result+ e_result <- connectionError conn =<< PQ.execParams conn query (runEncoder enc params) PQ.Binary+ case e_result of+ Left err -> return (Left (ConnectionError err))+ Right result -> do+ status <- PQ.resultStatus result+ if status == PQ.CommandOk || status == PQ.TuplesOk+ then return (Right result)+ else do+ msg <- PQ.resultErrorMessage result+ <&> maybe (T.pack (show status)) (decodeUtf8With lenientDecode)+ return (Left (ConnectionError msg)) query :: (ToSql p, FromSql r) => PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r)) query = queryWith toSql fromSql@@ -38,14 +46,10 @@ query_ :: ToSql p => PQ.Connection -> Query -> p -> IO (Either QueryError ()) query_ = queryWith_ toSql -data QueryError = QueryError Text | DecoderError DecoderError- deriving (Eq, Show, Typeable)-instance Exception QueryError--queryError :: PQ.Connection -> Maybe a -> ExceptT QueryError IO a-queryError _conn (Just a) = return a-queryError conn Nothing = do+connectionError :: PQ.Connection -> Maybe a -> IO (Either Text a)+connectionError _conn (Just a) = return (Right a)+connectionError conn Nothing = do m_msg <- liftIO $ PQ.errorMessage conn case m_msg of- Just msg -> throwE (QueryError (decodeUtf8With lenientDecode msg))- Nothing -> throwE (QueryError "No error message available")+ Just msg -> return (Left (decodeUtf8With lenientDecode msg))+ Nothing -> return (Left "No error message available")
src/Preql/Wire/ToSql.hs view
@@ -1,27 +1,30 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Preql.Wire.ToSql where -import Preql.Imports-import Preql.Wire.Types+import Preql.Imports+import Preql.Wire.Tuples (deriveToSqlTuple)+import Preql.Wire.Types -import Data.Functor.Contravariant-import Data.Functor.Contravariant.Divisible-import Data.Int-import Data.Time (Day, TimeOfDay, UTCTime, TimeZone)-import Data.UUID (UUID)+import Data.Functor.Contravariant+import Data.Int+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.UUID (UUID) import qualified ByteString.StrictBuilder as B import qualified Data.Aeson as JSON-import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Database.PostgreSQL.LibPQ as PQ-import qualified Database.PostgreSQL.Simple.TypeInfo.Static as OID import qualified PostgreSQL.Binary.Encoding as PGB+import qualified Preql.Wire.TypeInfo.Static as OID +-- | A @FieldEncoder@ for a type @a@ consists of a function from @a@ to+-- it's binary representation, and an Postgres OID which tells+-- Postgres it's type & how to decode it. data FieldEncoder a = FieldEncoder PQ.Oid (a -> B.Builder) instance Contravariant FieldEncoder where@@ -38,12 +41,18 @@ oneField :: FieldEncoder a -> RowEncoder a oneField enc = \p -> [runFieldEncoder enc p] +-- | Types which can be encoded to a single Postgres field. class ToSqlField a where toSqlField :: FieldEncoder a +-- | @ToSql a@ is sufficient to pass @a@ as parameters to a paramaterized query. class ToSql a where toSql :: RowEncoder a +instance ToSqlField Bool where+ toSqlField = FieldEncoder OID.boolOid PGB.bool+instance ToSql Bool where toSql = oneField toSqlField+ instance ToSqlField Int16 where toSqlField = FieldEncoder OID.int2Oid PGB.int2_int16 instance ToSql Int16 where toSql = oneField toSqlField@@ -114,13 +123,15 @@ instance ToSql UUID where toSql = oneField toSqlField -- | If you want to encode some more specific Haskell type via JSON,--- it is more efficient to use 'Data.Aeson.encode' and--- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- it is more efficient to use 'toSqlJsonField' rather than this -- instance. instance ToSqlField JSON.Value where toSqlField = FieldEncoder OID.jsonbOid PGB.jsonb_ast instance ToSql JSON.Value where toSql = oneField toSqlField +toSqlJsonField :: JSON.ToJSON a => FieldEncoder a+toSqlJsonField = FieldEncoder OID.jsonbOid (PGB.jsonb_bytes . BSL.toStrict . JSON.encode)+ instance ToSql () where toSql () = [] @@ -131,13 +142,29 @@ toSql (a, b, c) = [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b, runFieldEncoder toSqlField c] -instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d) => ToSql (a, b, c, d) where- toSql (a, b, c, d) =- [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b, runFieldEncoder toSqlField c- , runFieldEncoder toSqlField d]+-- The instances below all follow the pattern laid out by the tuple+-- instances above. The ones above are written out without the macro+-- to illustrate the pattern. -instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e) =>- ToSql (a, b, c, d, e) where- toSql (a, b, c, d, e) =- [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b, runFieldEncoder toSqlField c- , runFieldEncoder toSqlField d, runFieldEncoder toSqlField e]+$(deriveToSqlTuple 4)+$(deriveToSqlTuple 5)+$(deriveToSqlTuple 6)+$(deriveToSqlTuple 7)+$(deriveToSqlTuple 8)+$(deriveToSqlTuple 9)+$(deriveToSqlTuple 10)+$(deriveToSqlTuple 11)+$(deriveToSqlTuple 12)+$(deriveToSqlTuple 13)+$(deriveToSqlTuple 14)+$(deriveToSqlTuple 15)+$(deriveToSqlTuple 16)+$(deriveToSqlTuple 17)+$(deriveToSqlTuple 18)+$(deriveToSqlTuple 19)+$(deriveToSqlTuple 20)+$(deriveToSqlTuple 21)+$(deriveToSqlTuple 22)+$(deriveToSqlTuple 23)+$(deriveToSqlTuple 24)+$(deriveToSqlTuple 25)
+ src/Preql/Wire/Tuples.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Template Haskell macros to generate tuple instances for FromSql & ToSql++module Preql.Wire.Tuples where++import Language.Haskell.TH++alphabet :: [String]+alphabet = cycle (map (:"") ['a'..'z'])++deriveFromSqlTuple :: Int -> Q [Dec]+deriveFromSqlTuple n = do+ names <- traverse newName (take n alphabet)+ Just classN <- lookupTypeName "FromSql"+ Just methodN <- lookupValueName "fromSql"+ let+ context = [ ConT classN `AppT` VarT n | n <- names ]+ instanceHead = ConT classN `AppT` foldl AppT (TupleT n) (map VarT names)+ method = ValD+ (VarP methodN)+ (NormalB (foldl+ (\row field -> InfixE (Just row) (VarE '(<*>)) (Just field))+ (VarE 'pure `AppE` ConE (tupleDataName n))+ (replicate n (VarE methodN))))+ [] -- no where clause on the fromSql definition+ return [InstanceD Nothing context instanceHead [method]]++deriveToSqlTuple :: Int -> Q [Dec]+deriveToSqlTuple n = do+ names <- traverse newName (take n alphabet)+ Just classN <- lookupTypeName "ToSql"+ Just fieldN <- lookupTypeName "ToSqlField"+ Just toSql <- lookupValueName "toSql"+ Just runFieldEncoder <- lookupValueName "runFieldEncoder"+ Just toSqlField <- lookupValueName "toSqlField"+ let+ context = [ ConT fieldN `AppT` VarT n | n <- names ]+ instanceHead = ConT classN `AppT` foldl AppT (TupleT n) (map VarT names)+ method = FunD toSql+ [Clause+ [TupP (map VarP names)]+ (NormalB (ListE [ VarE runFieldEncoder `AppE` VarE toSqlField `AppE` VarE n | n <- names ]))+ []] -- no where clause on the toSql definition+ return [InstanceD Nothing context instanceHead [method]]
+ src/Preql/Wire/TypeInfo/Static.hs view
@@ -0,0 +1,1797 @@+-- |+-- Copyright: (c) 2011-2012 Leon P Smith+-- License: BSD3+-- Url: https://github.com/phadej/postgresql-simple/tree/master/src/Database/PostgreSQL/Simple/TypeInfo+--+-- This module contains portions of the @pg_type@ table that are relevant+-- to postgresql-simple and are believed to not change between PostgreSQL+-- versions.++-- Note that this file is generated by tools/GenTypeInfo.hs, and should+-- not be edited directly++module Preql.Wire.TypeInfo.Static+ ( TypeInfo(..)+ , staticTypeInfo+ , bool+ , boolOid+ , bytea+ , byteaOid+ , char+ , charOid+ , name+ , nameOid+ , int8+ , int8Oid+ , int2+ , int2Oid+ , int4+ , int4Oid+ , regproc+ , regprocOid+ , text+ , textOid+ , oid+ , oidOid+ , tid+ , tidOid+ , xid+ , xidOid+ , cid+ , cidOid+ , xml+ , xmlOid+ , point+ , pointOid+ , lseg+ , lsegOid+ , path+ , pathOid+ , box+ , boxOid+ , polygon+ , polygonOid+ , line+ , lineOid+ , cidr+ , cidrOid+ , float4+ , float4Oid+ , float8+ , float8Oid+ , unknown+ , unknownOid+ , circle+ , circleOid+ , money+ , moneyOid+ , macaddr+ , macaddrOid+ , inet+ , inetOid+ , bpchar+ , bpcharOid+ , varchar+ , varcharOid+ , date+ , dateOid+ , time+ , timeOid+ , timestamp+ , timestampOid+ , timestamptz+ , timestamptzOid+ , interval+ , intervalOid+ , timetz+ , timetzOid+ , bit+ , bitOid+ , varbit+ , varbitOid+ , numeric+ , numericOid+ , refcursor+ , refcursorOid+ , record+ , recordOid+ , void+ , voidOid+ , array_record+ , array_recordOid+ , regprocedure+ , regprocedureOid+ , regoper+ , regoperOid+ , regoperator+ , regoperatorOid+ , regclass+ , regclassOid+ , regtype+ , regtypeOid+ , uuid+ , uuidOid+ , json+ , jsonOid+ , jsonb+ , jsonbOid+ , int2vector+ , int2vectorOid+ , oidvector+ , oidvectorOid+ , array_xml+ , array_xmlOid+ , array_json+ , array_jsonOid+ , array_line+ , array_lineOid+ , array_cidr+ , array_cidrOid+ , array_circle+ , array_circleOid+ , array_money+ , array_moneyOid+ , array_bool+ , array_boolOid+ , array_bytea+ , array_byteaOid+ , array_char+ , array_charOid+ , array_name+ , array_nameOid+ , array_int2+ , array_int2Oid+ , array_int2vector+ , array_int2vectorOid+ , array_int4+ , array_int4Oid+ , array_regproc+ , array_regprocOid+ , array_text+ , array_textOid+ , array_tid+ , array_tidOid+ , array_xid+ , array_xidOid+ , array_cid+ , array_cidOid+ , array_oidvector+ , array_oidvectorOid+ , array_bpchar+ , array_bpcharOid+ , array_varchar+ , array_varcharOid+ , array_int8+ , array_int8Oid+ , array_point+ , array_pointOid+ , array_lseg+ , array_lsegOid+ , array_path+ , array_pathOid+ , array_box+ , array_boxOid+ , array_float4+ , array_float4Oid+ , array_float8+ , array_float8Oid+ , array_polygon+ , array_polygonOid+ , array_oid+ , array_oidOid+ , array_macaddr+ , array_macaddrOid+ , array_inet+ , array_inetOid+ , array_timestamp+ , array_timestampOid+ , array_date+ , array_dateOid+ , array_time+ , array_timeOid+ , array_timestamptz+ , array_timestamptzOid+ , array_interval+ , array_intervalOid+ , array_numeric+ , array_numericOid+ , array_timetz+ , array_timetzOid+ , array_bit+ , array_bitOid+ , array_varbit+ , array_varbitOid+ , array_refcursor+ , array_refcursorOid+ , array_regprocedure+ , array_regprocedureOid+ , array_regoper+ , array_regoperOid+ , array_regoperator+ , array_regoperatorOid+ , array_regclass+ , array_regclassOid+ , array_regtype+ , array_regtypeOid+ , array_uuid+ , array_uuidOid+ , array_jsonb+ , array_jsonbOid+ , int4range+ , int4rangeOid+ , _int4range+ , _int4rangeOid+ , numrange+ , numrangeOid+ , _numrange+ , _numrangeOid+ , tsrange+ , tsrangeOid+ , _tsrange+ , _tsrangeOid+ , tstzrange+ , tstzrangeOid+ , _tstzrange+ , _tstzrangeOid+ , daterange+ , daterangeOid+ , _daterange+ , _daterangeOid+ , int8range+ , int8rangeOid+ , _int8range+ , _int8rangeOid+ ) where++import Database.PostgreSQL.LibPQ (Oid(..))+import Preql.Wire.TypeInfo.Types++staticTypeInfo :: Oid -> Maybe TypeInfo+staticTypeInfo (Oid x) = case x of+ 16 -> Just bool+ 17 -> Just bytea+ 18 -> Just char+ 19 -> Just name+ 20 -> Just int8+ 21 -> Just int2+ 23 -> Just int4+ 24 -> Just regproc+ 25 -> Just text+ 26 -> Just oid+ 27 -> Just tid+ 28 -> Just xid+ 29 -> Just cid+ 142 -> Just xml+ 600 -> Just point+ 601 -> Just lseg+ 602 -> Just path+ 603 -> Just box+ 604 -> Just polygon+ 628 -> Just line+ 650 -> Just cidr+ 700 -> Just float4+ 701 -> Just float8+ 705 -> Just unknown+ 718 -> Just circle+ 790 -> Just money+ 829 -> Just macaddr+ 869 -> Just inet+ 1042 -> Just bpchar+ 1043 -> Just varchar+ 1082 -> Just date+ 1083 -> Just time+ 1114 -> Just timestamp+ 1184 -> Just timestamptz+ 1186 -> Just interval+ 1266 -> Just timetz+ 1560 -> Just bit+ 1562 -> Just varbit+ 1700 -> Just numeric+ 1790 -> Just refcursor+ 2249 -> Just record+ 2278 -> Just void+ 2287 -> Just array_record+ 2202 -> Just regprocedure+ 2203 -> Just regoper+ 2204 -> Just regoperator+ 2205 -> Just regclass+ 2206 -> Just regtype+ 2950 -> Just uuid+ 114 -> Just json+ 3802 -> Just jsonb+ 22 -> Just int2vector+ 30 -> Just oidvector+ 143 -> Just array_xml+ 199 -> Just array_json+ 629 -> Just array_line+ 651 -> Just array_cidr+ 719 -> Just array_circle+ 791 -> Just array_money+ 1000 -> Just array_bool+ 1001 -> Just array_bytea+ 1002 -> Just array_char+ 1003 -> Just array_name+ 1005 -> Just array_int2+ 1006 -> Just array_int2vector+ 1007 -> Just array_int4+ 1008 -> Just array_regproc+ 1009 -> Just array_text+ 1010 -> Just array_tid+ 1011 -> Just array_xid+ 1012 -> Just array_cid+ 1013 -> Just array_oidvector+ 1014 -> Just array_bpchar+ 1015 -> Just array_varchar+ 1016 -> Just array_int8+ 1017 -> Just array_point+ 1018 -> Just array_lseg+ 1019 -> Just array_path+ 1020 -> Just array_box+ 1021 -> Just array_float4+ 1022 -> Just array_float8+ 1027 -> Just array_polygon+ 1028 -> Just array_oid+ 1040 -> Just array_macaddr+ 1041 -> Just array_inet+ 1115 -> Just array_timestamp+ 1182 -> Just array_date+ 1183 -> Just array_time+ 1185 -> Just array_timestamptz+ 1187 -> Just array_interval+ 1231 -> Just array_numeric+ 1270 -> Just array_timetz+ 1561 -> Just array_bit+ 1563 -> Just array_varbit+ 2201 -> Just array_refcursor+ 2207 -> Just array_regprocedure+ 2208 -> Just array_regoper+ 2209 -> Just array_regoperator+ 2210 -> Just array_regclass+ 2211 -> Just array_regtype+ 2951 -> Just array_uuid+ 3807 -> Just array_jsonb+ 3904 -> Just int4range+ 3905 -> Just _int4range+ 3906 -> Just numrange+ 3907 -> Just _numrange+ 3908 -> Just tsrange+ 3909 -> Just _tsrange+ 3910 -> Just tstzrange+ 3911 -> Just _tstzrange+ 3912 -> Just daterange+ 3913 -> Just _daterange+ 3926 -> Just int8range+ 3927 -> Just _int8range+ _ -> Nothing++bool :: TypeInfo+bool = Basic {+ typoid = boolOid,+ typcategory = 'B',+ typdelim = ',',+ typname = "bool"+ }++boolOid :: Oid+boolOid = Oid 16+{-# INLINE boolOid #-}++bytea :: TypeInfo+bytea = Basic {+ typoid = byteaOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "bytea"+ }++byteaOid :: Oid+byteaOid = Oid 17+{-# INLINE byteaOid #-}++char :: TypeInfo+char = Basic {+ typoid = charOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "char"+ }++charOid :: Oid+charOid = Oid 18+{-# INLINE charOid #-}++name :: TypeInfo+name = Basic {+ typoid = nameOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "name"+ }++nameOid :: Oid+nameOid = Oid 19+{-# INLINE nameOid #-}++int8 :: TypeInfo+int8 = Basic {+ typoid = int8Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "int8"+ }++int8Oid :: Oid+int8Oid = Oid 20+{-# INLINE int8Oid #-}++int2 :: TypeInfo+int2 = Basic {+ typoid = int2Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "int2"+ }++int2Oid :: Oid+int2Oid = Oid 21+{-# INLINE int2Oid #-}++int4 :: TypeInfo+int4 = Basic {+ typoid = int4Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "int4"+ }++int4Oid :: Oid+int4Oid = Oid 23+{-# INLINE int4Oid #-}++regproc :: TypeInfo+regproc = Basic {+ typoid = regprocOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regproc"+ }++regprocOid :: Oid+regprocOid = Oid 24+{-# INLINE regprocOid #-}++text :: TypeInfo+text = Basic {+ typoid = textOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "text"+ }++textOid :: Oid+textOid = Oid 25+{-# INLINE textOid #-}++oid :: TypeInfo+oid = Basic {+ typoid = oidOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "oid"+ }++oidOid :: Oid+oidOid = Oid 26+{-# INLINE oidOid #-}++tid :: TypeInfo+tid = Basic {+ typoid = tidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "tid"+ }++tidOid :: Oid+tidOid = Oid 27+{-# INLINE tidOid #-}++xid :: TypeInfo+xid = Basic {+ typoid = xidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "xid"+ }++xidOid :: Oid+xidOid = Oid 28+{-# INLINE xidOid #-}++cid :: TypeInfo+cid = Basic {+ typoid = cidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "cid"+ }++cidOid :: Oid+cidOid = Oid 29+{-# INLINE cidOid #-}++xml :: TypeInfo+xml = Basic {+ typoid = xmlOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "xml"+ }++xmlOid :: Oid+xmlOid = Oid 142+{-# INLINE xmlOid #-}++point :: TypeInfo+point = Basic {+ typoid = pointOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "point"+ }++pointOid :: Oid+pointOid = Oid 600+{-# INLINE pointOid #-}++lseg :: TypeInfo+lseg = Basic {+ typoid = lsegOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "lseg"+ }++lsegOid :: Oid+lsegOid = Oid 601+{-# INLINE lsegOid #-}++path :: TypeInfo+path = Basic {+ typoid = pathOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "path"+ }++pathOid :: Oid+pathOid = Oid 602+{-# INLINE pathOid #-}++box :: TypeInfo+box = Basic {+ typoid = boxOid,+ typcategory = 'G',+ typdelim = ';',+ typname = "box"+ }++boxOid :: Oid+boxOid = Oid 603+{-# INLINE boxOid #-}++polygon :: TypeInfo+polygon = Basic {+ typoid = polygonOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "polygon"+ }++polygonOid :: Oid+polygonOid = Oid 604+{-# INLINE polygonOid #-}++line :: TypeInfo+line = Basic {+ typoid = lineOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "line"+ }++lineOid :: Oid+lineOid = Oid 628+{-# INLINE lineOid #-}++cidr :: TypeInfo+cidr = Basic {+ typoid = cidrOid,+ typcategory = 'I',+ typdelim = ',',+ typname = "cidr"+ }++cidrOid :: Oid+cidrOid = Oid 650+{-# INLINE cidrOid #-}++float4 :: TypeInfo+float4 = Basic {+ typoid = float4Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "float4"+ }++float4Oid :: Oid+float4Oid = Oid 700+{-# INLINE float4Oid #-}++float8 :: TypeInfo+float8 = Basic {+ typoid = float8Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "float8"+ }++float8Oid :: Oid+float8Oid = Oid 701+{-# INLINE float8Oid #-}++unknown :: TypeInfo+unknown = Basic {+ typoid = unknownOid,+ typcategory = 'X',+ typdelim = ',',+ typname = "unknown"+ }++unknownOid :: Oid+unknownOid = Oid 705+{-# INLINE unknownOid #-}++circle :: TypeInfo+circle = Basic {+ typoid = circleOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "circle"+ }++circleOid :: Oid+circleOid = Oid 718+{-# INLINE circleOid #-}++money :: TypeInfo+money = Basic {+ typoid = moneyOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "money"+ }++moneyOid :: Oid+moneyOid = Oid 790+{-# INLINE moneyOid #-}++macaddr :: TypeInfo+macaddr = Basic {+ typoid = macaddrOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "macaddr"+ }++macaddrOid :: Oid+macaddrOid = Oid 829+{-# INLINE macaddrOid #-}++inet :: TypeInfo+inet = Basic {+ typoid = inetOid,+ typcategory = 'I',+ typdelim = ',',+ typname = "inet"+ }++inetOid :: Oid+inetOid = Oid 869+{-# INLINE inetOid #-}++bpchar :: TypeInfo+bpchar = Basic {+ typoid = bpcharOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "bpchar"+ }++bpcharOid :: Oid+bpcharOid = Oid 1042+{-# INLINE bpcharOid #-}++varchar :: TypeInfo+varchar = Basic {+ typoid = varcharOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "varchar"+ }++varcharOid :: Oid+varcharOid = Oid 1043+{-# INLINE varcharOid #-}++date :: TypeInfo+date = Basic {+ typoid = dateOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "date"+ }++dateOid :: Oid+dateOid = Oid 1082+{-# INLINE dateOid #-}++time :: TypeInfo+time = Basic {+ typoid = timeOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "time"+ }++timeOid :: Oid+timeOid = Oid 1083+{-# INLINE timeOid #-}++timestamp :: TypeInfo+timestamp = Basic {+ typoid = timestampOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "timestamp"+ }++timestampOid :: Oid+timestampOid = Oid 1114+{-# INLINE timestampOid #-}++timestamptz :: TypeInfo+timestamptz = Basic {+ typoid = timestamptzOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "timestamptz"+ }++timestamptzOid :: Oid+timestamptzOid = Oid 1184+{-# INLINE timestamptzOid #-}++interval :: TypeInfo+interval = Basic {+ typoid = intervalOid,+ typcategory = 'T',+ typdelim = ',',+ typname = "interval"+ }++intervalOid :: Oid+intervalOid = Oid 1186+{-# INLINE intervalOid #-}++timetz :: TypeInfo+timetz = Basic {+ typoid = timetzOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "timetz"+ }++timetzOid :: Oid+timetzOid = Oid 1266+{-# INLINE timetzOid #-}++bit :: TypeInfo+bit = Basic {+ typoid = bitOid,+ typcategory = 'V',+ typdelim = ',',+ typname = "bit"+ }++bitOid :: Oid+bitOid = Oid 1560+{-# INLINE bitOid #-}++varbit :: TypeInfo+varbit = Basic {+ typoid = varbitOid,+ typcategory = 'V',+ typdelim = ',',+ typname = "varbit"+ }++varbitOid :: Oid+varbitOid = Oid 1562+{-# INLINE varbitOid #-}++numeric :: TypeInfo+numeric = Basic {+ typoid = numericOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "numeric"+ }++numericOid :: Oid+numericOid = Oid 1700+{-# INLINE numericOid #-}++refcursor :: TypeInfo+refcursor = Basic {+ typoid = refcursorOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "refcursor"+ }++refcursorOid :: Oid+refcursorOid = Oid 1790+{-# INLINE refcursorOid #-}++record :: TypeInfo+record = Basic {+ typoid = recordOid,+ typcategory = 'P',+ typdelim = ',',+ typname = "record"+ }++recordOid :: Oid+recordOid = Oid 2249+{-# INLINE recordOid #-}++void :: TypeInfo+void = Basic {+ typoid = voidOid,+ typcategory = 'P',+ typdelim = ',',+ typname = "void"+ }++voidOid :: Oid+voidOid = Oid 2278+{-# INLINE voidOid #-}++array_record :: TypeInfo+array_record = Array {+ typoid = array_recordOid,+ typcategory = 'P',+ typdelim = ',',+ typname = "_record",+ typelem = record+ }++array_recordOid :: Oid+array_recordOid = Oid 2287+{-# INLINE array_recordOid #-}++regprocedure :: TypeInfo+regprocedure = Basic {+ typoid = regprocedureOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regprocedure"+ }++regprocedureOid :: Oid+regprocedureOid = Oid 2202+{-# INLINE regprocedureOid #-}++regoper :: TypeInfo+regoper = Basic {+ typoid = regoperOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoper"+ }++regoperOid :: Oid+regoperOid = Oid 2203+{-# INLINE regoperOid #-}++regoperator :: TypeInfo+regoperator = Basic {+ typoid = regoperatorOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoperator"+ }++regoperatorOid :: Oid+regoperatorOid = Oid 2204+{-# INLINE regoperatorOid #-}++regclass :: TypeInfo+regclass = Basic {+ typoid = regclassOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regclass"+ }++regclassOid :: Oid+regclassOid = Oid 2205+{-# INLINE regclassOid #-}++regtype :: TypeInfo+regtype = Basic {+ typoid = regtypeOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regtype"+ }++regtypeOid :: Oid+regtypeOid = Oid 2206+{-# INLINE regtypeOid #-}++uuid :: TypeInfo+uuid = Basic {+ typoid = uuidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "uuid"+ }++uuidOid :: Oid+uuidOid = Oid 2950+{-# INLINE uuidOid #-}++json :: TypeInfo+json = Basic {+ typoid = jsonOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "json"+ }++jsonOid :: Oid+jsonOid = Oid 114+{-# INLINE jsonOid #-}++jsonb :: TypeInfo+jsonb = Basic {+ typoid = jsonbOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "jsonb"+ }++jsonbOid :: Oid+jsonbOid = Oid 3802+{-# INLINE jsonbOid #-}++int2vector :: TypeInfo+int2vector = Array {+ typoid = int2vectorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "int2vector",+ typelem = int2+ }++int2vectorOid :: Oid+int2vectorOid = Oid 22+{-# INLINE int2vectorOid #-}++oidvector :: TypeInfo+oidvector = Array {+ typoid = oidvectorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "oidvector",+ typelem = oid+ }++oidvectorOid :: Oid+oidvectorOid = Oid 30+{-# INLINE oidvectorOid #-}++array_xml :: TypeInfo+array_xml = Array {+ typoid = array_xmlOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_xml",+ typelem = xml+ }++array_xmlOid :: Oid+array_xmlOid = Oid 143+{-# INLINE array_xmlOid #-}++array_json :: TypeInfo+array_json = Array {+ typoid = array_jsonOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_json",+ typelem = json+ }++array_jsonOid :: Oid+array_jsonOid = Oid 199+{-# INLINE array_jsonOid #-}++array_line :: TypeInfo+array_line = Array {+ typoid = array_lineOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_line",+ typelem = line+ }++array_lineOid :: Oid+array_lineOid = Oid 629+{-# INLINE array_lineOid #-}++array_cidr :: TypeInfo+array_cidr = Array {+ typoid = array_cidrOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_cidr",+ typelem = cidr+ }++array_cidrOid :: Oid+array_cidrOid = Oid 651+{-# INLINE array_cidrOid #-}++array_circle :: TypeInfo+array_circle = Array {+ typoid = array_circleOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_circle",+ typelem = circle+ }++array_circleOid :: Oid+array_circleOid = Oid 719+{-# INLINE array_circleOid #-}++array_money :: TypeInfo+array_money = Array {+ typoid = array_moneyOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_money",+ typelem = money+ }++array_moneyOid :: Oid+array_moneyOid = Oid 791+{-# INLINE array_moneyOid #-}++array_bool :: TypeInfo+array_bool = Array {+ typoid = array_boolOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bool",+ typelem = bool+ }++array_boolOid :: Oid+array_boolOid = Oid 1000+{-# INLINE array_boolOid #-}++array_bytea :: TypeInfo+array_bytea = Array {+ typoid = array_byteaOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bytea",+ typelem = bytea+ }++array_byteaOid :: Oid+array_byteaOid = Oid 1001+{-# INLINE array_byteaOid #-}++array_char :: TypeInfo+array_char = Array {+ typoid = array_charOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_char",+ typelem = char+ }++array_charOid :: Oid+array_charOid = Oid 1002+{-# INLINE array_charOid #-}++array_name :: TypeInfo+array_name = Array {+ typoid = array_nameOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_name",+ typelem = name+ }++array_nameOid :: Oid+array_nameOid = Oid 1003+{-# INLINE array_nameOid #-}++array_int2 :: TypeInfo+array_int2 = Array {+ typoid = array_int2Oid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int2",+ typelem = int2+ }++array_int2Oid :: Oid+array_int2Oid = Oid 1005+{-# INLINE array_int2Oid #-}++array_int2vector :: TypeInfo+array_int2vector = Array {+ typoid = array_int2vectorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int2vector",+ typelem = int2vector+ }++array_int2vectorOid :: Oid+array_int2vectorOid = Oid 1006+{-# INLINE array_int2vectorOid #-}++array_int4 :: TypeInfo+array_int4 = Array {+ typoid = array_int4Oid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4",+ typelem = int4+ }++array_int4Oid :: Oid+array_int4Oid = Oid 1007+{-# INLINE array_int4Oid #-}++array_regproc :: TypeInfo+array_regproc = Array {+ typoid = array_regprocOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regproc",+ typelem = regproc+ }++array_regprocOid :: Oid+array_regprocOid = Oid 1008+{-# INLINE array_regprocOid #-}++array_text :: TypeInfo+array_text = Array {+ typoid = array_textOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_text",+ typelem = text+ }++array_textOid :: Oid+array_textOid = Oid 1009+{-# INLINE array_textOid #-}++array_tid :: TypeInfo+array_tid = Array {+ typoid = array_tidOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tid",+ typelem = tid+ }++array_tidOid :: Oid+array_tidOid = Oid 1010+{-# INLINE array_tidOid #-}++array_xid :: TypeInfo+array_xid = Array {+ typoid = array_xidOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_xid",+ typelem = xid+ }++array_xidOid :: Oid+array_xidOid = Oid 1011+{-# INLINE array_xidOid #-}++array_cid :: TypeInfo+array_cid = Array {+ typoid = array_cidOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_cid",+ typelem = cid+ }++array_cidOid :: Oid+array_cidOid = Oid 1012+{-# INLINE array_cidOid #-}++array_oidvector :: TypeInfo+array_oidvector = Array {+ typoid = array_oidvectorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_oidvector",+ typelem = oidvector+ }++array_oidvectorOid :: Oid+array_oidvectorOid = Oid 1013+{-# INLINE array_oidvectorOid #-}++array_bpchar :: TypeInfo+array_bpchar = Array {+ typoid = array_bpcharOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bpchar",+ typelem = bpchar+ }++array_bpcharOid :: Oid+array_bpcharOid = Oid 1014+{-# INLINE array_bpcharOid #-}++array_varchar :: TypeInfo+array_varchar = Array {+ typoid = array_varcharOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_varchar",+ typelem = varchar+ }++array_varcharOid :: Oid+array_varcharOid = Oid 1015+{-# INLINE array_varcharOid #-}++array_int8 :: TypeInfo+array_int8 = Array {+ typoid = array_int8Oid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8",+ typelem = int8+ }++array_int8Oid :: Oid+array_int8Oid = Oid 1016+{-# INLINE array_int8Oid #-}++array_point :: TypeInfo+array_point = Array {+ typoid = array_pointOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_point",+ typelem = point+ }++array_pointOid :: Oid+array_pointOid = Oid 1017+{-# INLINE array_pointOid #-}++array_lseg :: TypeInfo+array_lseg = Array {+ typoid = array_lsegOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_lseg",+ typelem = lseg+ }++array_lsegOid :: Oid+array_lsegOid = Oid 1018+{-# INLINE array_lsegOid #-}++array_path :: TypeInfo+array_path = Array {+ typoid = array_pathOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_path",+ typelem = path+ }++array_pathOid :: Oid+array_pathOid = Oid 1019+{-# INLINE array_pathOid #-}++array_box :: TypeInfo+array_box = Array {+ typoid = array_boxOid,+ typcategory = 'A',+ typdelim = ';',+ typname = "_box",+ typelem = box+ }++array_boxOid :: Oid+array_boxOid = Oid 1020+{-# INLINE array_boxOid #-}++array_float4 :: TypeInfo+array_float4 = Array {+ typoid = array_float4Oid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_float4",+ typelem = float4+ }++array_float4Oid :: Oid+array_float4Oid = Oid 1021+{-# INLINE array_float4Oid #-}++array_float8 :: TypeInfo+array_float8 = Array {+ typoid = array_float8Oid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_float8",+ typelem = float8+ }++array_float8Oid :: Oid+array_float8Oid = Oid 1022+{-# INLINE array_float8Oid #-}++array_polygon :: TypeInfo+array_polygon = Array {+ typoid = array_polygonOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_polygon",+ typelem = polygon+ }++array_polygonOid :: Oid+array_polygonOid = Oid 1027+{-# INLINE array_polygonOid #-}++array_oid :: TypeInfo+array_oid = Array {+ typoid = array_oidOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_oid",+ typelem = oid+ }++array_oidOid :: Oid+array_oidOid = Oid 1028+{-# INLINE array_oidOid #-}++array_macaddr :: TypeInfo+array_macaddr = Array {+ typoid = array_macaddrOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_macaddr",+ typelem = macaddr+ }++array_macaddrOid :: Oid+array_macaddrOid = Oid 1040+{-# INLINE array_macaddrOid #-}++array_inet :: TypeInfo+array_inet = Array {+ typoid = array_inetOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_inet",+ typelem = inet+ }++array_inetOid :: Oid+array_inetOid = Oid 1041+{-# INLINE array_inetOid #-}++array_timestamp :: TypeInfo+array_timestamp = Array {+ typoid = array_timestampOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timestamp",+ typelem = timestamp+ }++array_timestampOid :: Oid+array_timestampOid = Oid 1115+{-# INLINE array_timestampOid #-}++array_date :: TypeInfo+array_date = Array {+ typoid = array_dateOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_date",+ typelem = date+ }++array_dateOid :: Oid+array_dateOid = Oid 1182+{-# INLINE array_dateOid #-}++array_time :: TypeInfo+array_time = Array {+ typoid = array_timeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_time",+ typelem = time+ }++array_timeOid :: Oid+array_timeOid = Oid 1183+{-# INLINE array_timeOid #-}++array_timestamptz :: TypeInfo+array_timestamptz = Array {+ typoid = array_timestamptzOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timestamptz",+ typelem = timestamptz+ }++array_timestamptzOid :: Oid+array_timestamptzOid = Oid 1185+{-# INLINE array_timestamptzOid #-}++array_interval :: TypeInfo+array_interval = Array {+ typoid = array_intervalOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_interval",+ typelem = interval+ }++array_intervalOid :: Oid+array_intervalOid = Oid 1187+{-# INLINE array_intervalOid #-}++array_numeric :: TypeInfo+array_numeric = Array {+ typoid = array_numericOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numeric",+ typelem = numeric+ }++array_numericOid :: Oid+array_numericOid = Oid 1231+{-# INLINE array_numericOid #-}++array_timetz :: TypeInfo+array_timetz = Array {+ typoid = array_timetzOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timetz",+ typelem = timetz+ }++array_timetzOid :: Oid+array_timetzOid = Oid 1270+{-# INLINE array_timetzOid #-}++array_bit :: TypeInfo+array_bit = Array {+ typoid = array_bitOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bit",+ typelem = bit+ }++array_bitOid :: Oid+array_bitOid = Oid 1561+{-# INLINE array_bitOid #-}++array_varbit :: TypeInfo+array_varbit = Array {+ typoid = array_varbitOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_varbit",+ typelem = varbit+ }++array_varbitOid :: Oid+array_varbitOid = Oid 1563+{-# INLINE array_varbitOid #-}++array_refcursor :: TypeInfo+array_refcursor = Array {+ typoid = array_refcursorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_refcursor",+ typelem = refcursor+ }++array_refcursorOid :: Oid+array_refcursorOid = Oid 2201+{-# INLINE array_refcursorOid #-}++array_regprocedure :: TypeInfo+array_regprocedure = Array {+ typoid = array_regprocedureOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regprocedure",+ typelem = regprocedure+ }++array_regprocedureOid :: Oid+array_regprocedureOid = Oid 2207+{-# INLINE array_regprocedureOid #-}++array_regoper :: TypeInfo+array_regoper = Array {+ typoid = array_regoperOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regoper",+ typelem = regoper+ }++array_regoperOid :: Oid+array_regoperOid = Oid 2208+{-# INLINE array_regoperOid #-}++array_regoperator :: TypeInfo+array_regoperator = Array {+ typoid = array_regoperatorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regoperator",+ typelem = regoperator+ }++array_regoperatorOid :: Oid+array_regoperatorOid = Oid 2209+{-# INLINE array_regoperatorOid #-}++array_regclass :: TypeInfo+array_regclass = Array {+ typoid = array_regclassOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regclass",+ typelem = regclass+ }++array_regclassOid :: Oid+array_regclassOid = Oid 2210+{-# INLINE array_regclassOid #-}++array_regtype :: TypeInfo+array_regtype = Array {+ typoid = array_regtypeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regtype",+ typelem = regtype+ }++array_regtypeOid :: Oid+array_regtypeOid = Oid 2211+{-# INLINE array_regtypeOid #-}++array_uuid :: TypeInfo+array_uuid = Array {+ typoid = array_uuidOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_uuid",+ typelem = uuid+ }++array_uuidOid :: Oid+array_uuidOid = Oid 2951+{-# INLINE array_uuidOid #-}++array_jsonb :: TypeInfo+array_jsonb = Array {+ typoid = array_jsonbOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_jsonb",+ typelem = jsonb+ }++array_jsonbOid :: Oid+array_jsonbOid = Oid 3807+{-# INLINE array_jsonbOid #-}++int4range :: TypeInfo+int4range = Range {+ typoid = int4rangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "int4range",+ rngsubtype = int4+ }++int4rangeOid :: Oid+int4rangeOid = Oid 3904+{-# INLINE int4rangeOid #-}++_int4range :: TypeInfo+_int4range = Array {+ typoid = _int4rangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4range",+ typelem = int4range+ }++_int4rangeOid :: Oid+_int4rangeOid = Oid 3905+{-# INLINE _int4rangeOid #-}++numrange :: TypeInfo+numrange = Range {+ typoid = numrangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "numrange",+ rngsubtype = numeric+ }++numrangeOid :: Oid+numrangeOid = Oid 3906+{-# INLINE numrangeOid #-}++_numrange :: TypeInfo+_numrange = Array {+ typoid = _numrangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numrange",+ typelem = numrange+ }++_numrangeOid :: Oid+_numrangeOid = Oid 3907+{-# INLINE _numrangeOid #-}++tsrange :: TypeInfo+tsrange = Range {+ typoid = tsrangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "tsrange",+ rngsubtype = timestamp+ }++tsrangeOid :: Oid+tsrangeOid = Oid 3908+{-# INLINE tsrangeOid #-}++_tsrange :: TypeInfo+_tsrange = Array {+ typoid = _tsrangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tsrange",+ typelem = tsrange+ }++_tsrangeOid :: Oid+_tsrangeOid = Oid 3909+{-# INLINE _tsrangeOid #-}++tstzrange :: TypeInfo+tstzrange = Range {+ typoid = tstzrangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "tstzrange",+ rngsubtype = timestamptz+ }++tstzrangeOid :: Oid+tstzrangeOid = Oid 3910+{-# INLINE tstzrangeOid #-}++_tstzrange :: TypeInfo+_tstzrange = Array {+ typoid = _tstzrangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tstzrange",+ typelem = tstzrange+ }++_tstzrangeOid :: Oid+_tstzrangeOid = Oid 3911+{-# INLINE _tstzrangeOid #-}++daterange :: TypeInfo+daterange = Range {+ typoid = daterangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "daterange",+ rngsubtype = date+ }++daterangeOid :: Oid+daterangeOid = Oid 3912+{-# INLINE daterangeOid #-}++_daterange :: TypeInfo+_daterange = Array {+ typoid = _daterangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_daterange",+ typelem = daterange+ }++_daterangeOid :: Oid+_daterangeOid = Oid 3913+{-# INLINE _daterangeOid #-}++int8range :: TypeInfo+int8range = Range {+ typoid = int8rangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "int8range",+ rngsubtype = int8+ }++int8rangeOid :: Oid+int8rangeOid = Oid 3926+{-# INLINE int8rangeOid #-}++_int8range :: TypeInfo+_int8range = Array {+ typoid = _int8rangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8range",+ typelem = int8range+ }++_int8rangeOid :: Oid+_int8rangeOid = Oid 3927+{-# INLINE _int8rangeOid #-}
+ src/Preql/Wire/TypeInfo/Types.hs view
@@ -0,0 +1,52 @@+-- |+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Url: https://github.com/phadej/postgresql-simple/tree/master/src/Database/PostgreSQL/Simple/TypeInfo+------------------------------------------------------------------------------++module Preql.Wire.TypeInfo.Types where++import Data.ByteString(ByteString)+import Database.PostgreSQL.LibPQ(Oid)+import Data.Vector(Vector)++-- | A structure representing some of the metadata regarding a PostgreSQL+-- type, mostly taken from the @pg_type@ table.++data TypeInfo++ = Basic { typoid :: {-# UNPACK #-} !Oid+ , typcategory :: {-# UNPACK #-} !Char+ , typdelim :: {-# UNPACK #-} !Char+ , typname :: !ByteString+ }++ | Array { typoid :: {-# UNPACK #-} !Oid+ , typcategory :: {-# UNPACK #-} !Char+ , typdelim :: {-# UNPACK #-} !Char+ , typname :: !ByteString+ , typelem :: !TypeInfo+ }++ | Range { typoid :: {-# UNPACK #-} !Oid+ , typcategory :: {-# UNPACK #-} !Char+ , typdelim :: {-# UNPACK #-} !Char+ , typname :: !ByteString+ , rngsubtype :: !TypeInfo+ }++ | Composite { typoid :: {-# UNPACK #-} !Oid+ , typcategory :: {-# UNPACK #-} !Char+ , typdelim :: {-# UNPACK #-} !Char+ , typname :: !ByteString+ , typrelid :: {-# UNPACK #-} !Oid+ , attributes :: !(Vector Attribute)+ }++ deriving (Show)++data Attribute+ = Attribute { attname :: !ByteString+ , atttype :: !TypeInfo+ }+ deriving (Show)
src/Preql/Wire/Types.hs view
@@ -3,3 +3,4 @@ import Data.Time (TimeOfDay, TimeZone) data TimeTZ = TimeTZ !TimeOfDay !TimeZone+ deriving (Show, Eq)
+ test/Test.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++import Test.Wire (connectionString, wire)++import Preql.QuasiQuoter.Raw.TH+import Preql.Wire++import Data.Either+import Data.Int+import Data.List.NonEmpty (NonEmpty(..))+import Database.PostgreSQL.LibPQ (connectdb, finish)+import Prelude hiding (Ordering(..), lex)+import Test.Tasty+import Test.Tasty.HUnit++import qualified Preql.QuasiQuoter.Raw.Lex as L+import qualified Preql.Wire.Query as W++import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++main :: IO ()+main = defaultMain $ testGroup "crispy-broccoli"+ [ antiquotes+ , wire+ -- , integration+ ]+++-- integration :: TestTree+-- integration = withResource (connectdb connectionString) finish $ \db -> testGroup "integration"+ -- [ testCase "SELECT foo, bar FROM baz" $ do+ -- conn <- db+ -- result <- query conn [sql|SELECT foo, bar FROM baz |]+ -- assertEqual "" [(1, "one"), (2, "two")] (result :: [(Int, T.Text)])+ -- ]+-- , testCase "with params" $ do+-- conn <- db+-- result <- query conn $ [aritySql| SELECT foo, bar FROM baz WHERE foo = $1|] (1 :: Int)+-- assertEqual "" [(1, "one")] (result :: [(Int, T.Text)])+-- , testCase "antiquote, 2 params" $ do+-- conn <- db+-- let+-- foo0 = 1 :: Int+-- bar0 = "one" :: T.Text+-- result <- query conn [aritySql| SELECT foo, bar FROM baz WHERE foo = ${foo0} AND bar = ${bar0}|]+-- assertEqual "" [(1, "one")] (result :: [(Int, T.Text)])+-- , testCase "antiquote, 1 params" $ do+-- conn <- db+-- let foo0 = 1 :: Int+-- result <- query conn [aritySql| SELECT foo, bar FROM baz WHERE foo = ${foo0}|]+-- assertEqual "" [(1, "one")] (result :: [(Int, T.Text)])+-- ]++antiquotes :: TestTree+antiquotes = testGroup "antiquotes"+ [ testCase "numberAntiquotes" $+ assertEqual ""+ ("SELECT foo, bar FROM baz WHERE foo = $1", ["foo0"])+ (numberAntiquotes 0 [ L.Sql "SELECT foo, bar FROM baz WHERE foo = ", L.HaskellParam "foo0" ])+ ]
+ test/Test/Wire.hs view
@@ -0,0 +1,226 @@+{-# 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 Control.Exception (Exception, bracket_, throwIO)+import Control.Monad+import Data.ByteString (ByteString)+import Data.Either+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.Format.ISO8601 (iso8601ParseM)+#else+import Data.Time.Format (parseTimeM, defaultTimeLocale, iso8601DateFormat, ParseTime)+#endif+import Data.Text.Encoding (encodeUtf8)+import Data.Vector (Vector)+import System.Environment (lookupEnv)+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.UUID as UUID+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Preql.Wire.Query as W++wire :: TestTree+wire = withResource initDB PQ.finish $ \db -> testGroup "wire" $+ let+ inTransaction desc body = testCase desc $+ bracket_ (query_ "BEGIN TRANSACTION" ()) (query_ "ROLLBACK" ()) body+ query :: (ToSql p, FromSql r) => Query -> p -> IO (Either QueryError (Vector r))+ query q p = db >>= \conn -> W.query conn q p+ query_ :: (ToSql p) => Query -> p -> IO ()+ query_ q p = db >>= \conn -> W.query_ conn q p >>= either throwIO pure+ assertQuery :: (FromSql r, Eq r, Show r) => Vector r -> Query -> IO ()+ assertQuery expected q = assertEqual "" (Right expected) =<< query q () in+ [ testGroup "decoders"+ [ inTransaction "decode True" $+ assertQuery [True] "SELECT true"+ , inTransaction "decode False" $+ assertQuery [False] "SELECT false"+ , inTransaction "decode Int64 literal" $+ assertQuery [2^32 :: Int64] "SELECT (2^32)::int8"+ , inTransaction "decode Int32 literal" $+ assertQuery [2^16 :: Int32] "SELECT (2^16)::int4"+ , inTransaction "decode Int16 literal" $+ assertQuery [2^8 :: Int16] "SELECT (2^8)::int2"+ , inTransaction "decode Float literal" $+ assertQuery [2**32 :: Float] "SELECT (2^32)::float4"+ , inTransaction "decode Double literal" $+ assertQuery [2**32 :: Double] "SELECT (2^32)::float8"+ -- , inTransaction "decode Char literal" $+ -- assertQuery ['x'] "SELECT 'x'::char"+ , inTransaction "decode String literal" $+ assertQuery ["foo" :: String] "SELECT 'foo'::text"+ , inTransaction "decode Text literal" $+ assertQuery ["foo" :: Text] "SELECT 'foo'::text"+ , inTransaction "decode lazy Text literal" $+ assertQuery ["foo" :: TL.Text] "SELECT 'foo'::text"+ , inTransaction "decode byte array literal" $+ assertQuery ["foo" :: ByteString] "SELECT 'foo'::bytea"+ , inTransaction "decode UTCTime literal" $ do+ time <- iso8601ParseM "2020-03-19T21:43:00Z"+ assertQuery [time :: UTCTime] "SELECT '2020-03-19T21:43:00Z'::timestamptz"+ , inTransaction "decode Day literal" $ do+ time <- iso8601ParseM "2020-03-19"+ assertQuery [time :: Day] "SELECT '2020-03-19'::date"+ , inTransaction "decode time literal" $ do+ time <- iso8601ParseM "21:43:00"+ assertQuery [time :: TimeOfDay] "SELECT '21:43:00Z'::time"+ , inTransaction "decode TimeTZ literal" $ do+ time <- iso8601ParseM "21:43:00"+ zone <- iso8601ParseM "+05:00"+ assertQuery [TimeTZ time zone] "SELECT '21:43:00+05:00'::timetz"+ , inTransaction "decode UUID literal" $+ assertQuery [UUID.fromWords 0x01234567 0x89abcdef 0x01234567 0x89abcdef] "SELECT '01234567-89ab-cdef-0123-456789abcdef'::uuid"+ ]++ , testGroup "encoders"+ [ inTransaction "encode True" $ do+ query_ "INSERT INTO encoder_tests (b) VALUES ($1)" True+ assertQuery [True] "SELECT b FROM encoder_tests WHERE b is not null"+ , inTransaction "encode Int64" $ do+ let v = 12345 :: Int64+ query_ "INSERT INTO encoder_tests (i64) VALUES ($1)" v+ assertQuery [v] "SELECT i64 FROM encoder_tests WHERE i64 is not null"+ , inTransaction "encode Int32" $ do+ let v = 12345 :: Int32+ query_ "INSERT INTO encoder_tests (i32) VALUES ($1)" v+ assertQuery [v] "SELECT i32 FROM encoder_tests WHERE i32 is not null"+ , inTransaction "encode Int16" $ do+ let v = 12345 :: Int16+ query_ "INSERT INTO encoder_tests (i16) VALUES ($1)" v+ assertQuery [v] "SELECT i16 FROM encoder_tests WHERE i16 is not null"+ , inTransaction "encode Float" $ do+ let v = 12345.678 :: Float+ query_ "INSERT INTO encoder_tests (f) VALUES ($1)" v+ assertQuery [v] "SELECT f FROM encoder_tests WHERE f is not null"+ , inTransaction "encode Double" $ do+ let v = 12345.678 :: Double+ query_ "INSERT INTO encoder_tests (d) VALUES ($1)" v+ assertQuery [v] "SELECT d FROM encoder_tests WHERE d is not null"+ , inTransaction "encode strict Text" $ do+ let v = "foo" :: Text+ query_ "INSERT INTO encoder_tests (t) VALUES ($1)" v+ assertQuery [v] "SELECT t FROM encoder_tests WHERE t is not null"+ , inTransaction "encode lazy Text" $ do+ let v = "foo" :: TL.Text+ query_ "INSERT INTO encoder_tests (t) VALUES ($1)" v+ assertQuery [v] "SELECT t FROM encoder_tests WHERE t is not null"+ , inTransaction "encode String" $ do+ let v = "foo" :: String+ query_ "INSERT INTO encoder_tests (t) VALUES ($1)" v+ assertQuery [v] "SELECT t FROM encoder_tests WHERE t is not null"+ , inTransaction "encode UTCTime" $ do+ v :: UTCTime <- iso8601ParseM "2020-03-19T21:43:00Z"+ query_ "INSERT INTO encoder_tests (ts) VALUES ($1)" v+ assertQuery [v] "SELECT ts FROM encoder_tests WHERE ts is not null"+ , inTransaction "encode Day" $ do+ v :: Day <- iso8601ParseM "2020-03-19"+ query_ "INSERT INTO encoder_tests (day) VALUES ($1)" v+ assertQuery [v] "SELECT day FROM encoder_tests WHERE day is not null"+ , inTransaction "encode TimeOfDay" $ do+ v :: TimeOfDay <- iso8601ParseM "21:43:00"+ query_ "INSERT INTO encoder_tests (time) VALUES ($1)" v+ assertQuery [v] "SELECT time FROM encoder_tests WHERE time is not null"+ , inTransaction "encode TimeTZ" $ do+ v <- TimeTZ <$> iso8601ParseM "21:43:00" <*> iso8601ParseM "+05:00"+ query_ "INSERT INTO encoder_tests (ttz) VALUES ($1)" v+ assertQuery [v] "SELECT ttz FROM encoder_tests WHERE ttz is not null"+ , inTransaction "encode UUID" $ do+ let v = UUID.fromWords 0x01234567 0x89abcdef 0x01234567 0x89abcdef+ query_ "INSERT INTO encoder_tests (u) VALUES ($1)" v+ assertQuery [v] "SELECT u FROM encoder_tests WHERE u is not null"+ ]++ , testGroup "parameters & expressions"+ [ inTransaction "schema type mismatch causes runtime error" $+ assertBool "" . isLeft =<< query @() @Int32 "SELECT 2.5" ()+ , inTransaction "ignore later columns" $+ assertEqual "" (Right [2]) =<< query @() @Int32 "SELECT 2, 3" ()+ , inTransaction "parse a pair" $+ assertEqual "" (Right [(2, 3)]) =<< query @() @(Int32, Int32) "SELECT 2, 3" ()+ , inTransaction "add Int32 parameters" $+ assertEqual "" (Right [3]) =<< query @(Int32, Int32) @Int32 "SELECT $1 + $2" (1, 2)+ , inTransaction "add Int64 parameters" $+ assertEqual "" (Right [3]) =<< query @(Int64, Int64) @Int64 "SELECT $1 + $2" (1, 2)+ , inTransaction "add Float32 parameters" $+ assertEqual "" (Right [3]) =<< query @(Float, Float) @Float "SELECT $1 + $2" (1, 2)+ , inTransaction "add Float64 parameters" $+ assertEqual "" (Right [3]) =<< query @(Double, Double) @Double "SELECT $1 + $2" (1, 2)+ , inTransaction "add 3 Int32 parameters" $+ assertEqual "" (Right [6]) =<< query @(Int32, Int32, Int32) @Int32 "SELECT $1 + $2 + $3" (1, 2, 3)+ ]++ , testGroup "TH-derived instances"+ [ inTransaction "FromSql 4-tuple" $+ assertQuery [(1 :: Int64, 2 :: Int64, 3 :: Int64, 4 :: Int64)] "SELECT 1::int8, 2::int8, 3::int8, 4::int8 "+ , inTransaction "ToSql 4-tuple" $ do+ let v = (True, 2 :: Int16, 3 :: Int32, 4 :: Int64)+ 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"+ ]+ ]++initDB :: HasCallStack => IO PQ.Connection+initDB = do+ conn <- PQ.connectdb =<< connectionString+ status <- PQ.status conn+ unless (status == PQ.ConnectionOk) (throwIO =<< badConnection conn)+ void $ W.query_ conn "DROP TABLE IF EXISTS encoder_tests" ()+ void $ W.query_ conn "CREATE TABLE encoder_tests (b boolean, i16 int2, i32 int4, i64 int8, f float4, d float8, t text, by bytea, ts timestamptz, day date, time time, ttz timetz, u uuid)" ()+ return conn++connectionString :: IO ByteString+connectionString = do+ m_dbname <- lookupEnv "PREQL_TESTS_DB"+ let dbname = case m_dbname of+ Just s -> encodeUtf8 (T.pack s)+ Nothing -> "preql_tests"+ return $ "dbname=" <> dbname++data BadConnection = BadConnection+ { status :: PQ.ConnStatus+ , errorMessage :: ByteString+ , host :: ByteString+ , port :: ByteString+ , user :: ByteString+ } deriving (Show)+instance Exception BadConnection++badConnection :: PQ.Connection -> IO BadConnection+badConnection c = do+ status <- PQ.status c+ errorMessage <- fromMaybe "" <$> PQ.errorMessage c+ host <- fromMaybe "" <$> PQ.host c+ port <- fromMaybe "" <$> PQ.port c+ user <- fromMaybe "" <$> PQ.user c+ return BadConnection {..}++#if !MIN_VERSION_time(1,9,0)+class ParseTime8601 t where+ iso8601ParseM :: Monad m => String -> m t++instance ParseTime8601 UTCTime where+ iso8601ParseM = parseTimeM False defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%SZ"))+instance ParseTime8601 Day where+ iso8601ParseM = parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing)+instance ParseTime8601 TimeOfDay where+ iso8601ParseM = parseTimeM False defaultTimeLocale "%H:%M:%S"+instance ParseTime8601 TimeZone where+ iso8601ParseM = parseTimeM False defaultTimeLocale "%z"+#endif