diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright (c) 2019, Daniel Bergey +Copyright (c) 2011, Leon P Smith All rights reserved. diff --git a/preql.cabal b/preql.cabal --- a/preql.cabal +++ b/preql.cabal @@ -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 diff --git a/src/Preql.hs b/src/Preql.hs --- a/src/Preql.hs +++ b/src/Preql.hs @@ -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 diff --git a/src/Preql/Effect.hs b/src/Preql/Effect.hs --- a/src/Preql/Effect.hs +++ b/src/Preql/Effect.hs @@ -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 diff --git a/src/Preql/Effect/Internal.hs b/src/Preql/Effect/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Preql/Effect/Internal.hs @@ -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 diff --git a/src/Preql/Imports.hs b/src/Preql/Imports.hs --- a/src/Preql/Imports.hs +++ b/src/Preql/Imports.hs @@ -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) diff --git a/src/Preql/PQResultUtils.hs b/src/Preql/PQResultUtils.hs deleted file mode 100644 --- a/src/Preql/PQResultUtils.hs +++ /dev/null @@ -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' #-} diff --git a/src/Preql/QuasiQuoter/Raw/TH.hs b/src/Preql/QuasiQuoter/Raw/TH.hs --- a/src/Preql/QuasiQuoter/Raw/TH.hs +++ b/src/Preql/QuasiQuoter/Raw/TH.hs @@ -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 diff --git a/src/Preql/Wire.hs b/src/Preql/Wire.hs --- a/src/Preql/Wire.hs +++ b/src/Preql/Wire.hs @@ -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 diff --git a/src/Preql/Wire/Connection.hs b/src/Preql/Wire/Connection.hs deleted file mode 100644 --- a/src/Preql/Wire/Connection.hs +++ /dev/null @@ -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 diff --git a/src/Preql/Wire/Errors.hs b/src/Preql/Wire/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Preql/Wire/Errors.hs @@ -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) diff --git a/src/Preql/Wire/FromSql.hs b/src/Preql/Wire/FromSql.hs --- a/src/Preql/Wire/FromSql.hs +++ b/src/Preql/Wire/FromSql.hs @@ -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) diff --git a/src/Preql/Wire/Internal.hs b/src/Preql/Wire/Internal.hs --- a/src/Preql/Wire/Internal.hs +++ b/src/Preql/Wire/Internal.hs @@ -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) diff --git a/src/Preql/Wire/Orphans.hs b/src/Preql/Wire/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Preql/Wire/Orphans.hs @@ -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" diff --git a/src/Preql/Wire/Query.hs b/src/Preql/Wire/Query.hs --- a/src/Preql/Wire/Query.hs +++ b/src/Preql/Wire/Query.hs @@ -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") diff --git a/src/Preql/Wire/ToSql.hs b/src/Preql/Wire/ToSql.hs --- a/src/Preql/Wire/ToSql.hs +++ b/src/Preql/Wire/ToSql.hs @@ -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) diff --git a/src/Preql/Wire/Tuples.hs b/src/Preql/Wire/Tuples.hs new file mode 100644 --- /dev/null +++ b/src/Preql/Wire/Tuples.hs @@ -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]] diff --git a/src/Preql/Wire/TypeInfo/Static.hs b/src/Preql/Wire/TypeInfo/Static.hs new file mode 100644 --- /dev/null +++ b/src/Preql/Wire/TypeInfo/Static.hs @@ -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 #-} diff --git a/src/Preql/Wire/TypeInfo/Types.hs b/src/Preql/Wire/TypeInfo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Preql/Wire/TypeInfo/Types.hs @@ -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) diff --git a/src/Preql/Wire/Types.hs b/src/Preql/Wire/Types.hs --- a/src/Preql/Wire/Types.hs +++ b/src/Preql/Wire/Types.hs @@ -3,3 +3,4 @@ import Data.Time (TimeOfDay, TimeZone) data TimeTZ = TimeTZ !TimeOfDay !TimeZone + deriving (Show, Eq) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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" ]) + ] diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs new file mode 100644 --- /dev/null +++ b/test/Test/Wire.hs @@ -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