diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.5 (2021-01-10) + +- fix `deriveFromSql` which was completely unusable +- add benchmark / exe for speeed testing +- 3x improvement in decoding speed for this benchmark + # 0.4 (2021-01-07) - `select` quasiquoter that validates syntax diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Bench.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Main where + +import Preql +import qualified Preql.Wire.TypeInfo.Static as OID + +import Control.DeepSeq (NFData(..)) +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT) +import Criterion +import Criterion.Main +import Data.ByteString (ByteString) +import Data.Int +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Vector (Vector) +import System.Environment (lookupEnv) +import qualified Data.Text as T +import qualified Database.PostgreSQL.LibPQ as PQ +import qualified PostgreSQL.Binary.Decoding as PGB + +main :: IO () +main = do + conn <- connectDB + defaultMain + [ bench "pg_type" $ nfIO $ flip runReaderT conn $ do + let + typmod = -1 :: Int16 + isdefined = True + res <- query [sql| select typname, typnamespace, typowner, typlen, typbyval , typcategory, typispreferred, typisdefined, typdelim , typrelid, typelem, typarray from pg_type where typtypmod = ${typmod} and typisdefined = ${isdefined} |] + return (res :: Vector (PgName, PQ.Oid, PQ.Oid, Int16, Bool + , Char, Bool, Bool, Char + , PQ.Oid, PQ.Oid, PQ.Oid)) + ] + +connectDB :: IO PQ.Connection +connectDB = do + conn <- PQ.connectdb =<< connectionString + status <- PQ.status conn + unless (status == PQ.ConnectionOk) (error "bad connection") + 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 + +instance NFData PQ.Oid where + rnf (PQ.Oid oid) = rnf oid +instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9, NFData a10, NFData a11, NFData a12) => + NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where + rnf (x1,x2,x3,x4,x5,x6, x7, x8, x9, x10, x11, x12) = + rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 + `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 + `seq` rnf x11 `seq` rnf x12 + +deriving newtype instance NFData PgName diff --git a/preql.cabal b/preql.cabal --- a/preql.cabal +++ b/preql.cabal @@ -1,20 +1,22 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.3. -- -- see: https://github.com/sol/hpack -- --- hash: 879f97b745bc46aaf20841fb18d7111d51a84fb4a3194c782f7e99c972a8ead3 +-- hash: d56204964cb9b2be1a806f9feb77bc975fc037b053f1edf3b775c7dec9d2fed1 name: preql -version: 0.4 +version: 0.5 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. + @preql@ provides an effect type class `SQL`, a `select` quasiquoter + that checks SQL syntax at compile time, and a `sql` quasiquoter that + supports variable antiquotes, but does not attempt syntax + validation. . + For more details, read the [quickstart](https://github.com/bergey/preql#quickstart) or the [vision](https://github.com/bergey/preql#vision-parsing-sql-in-haskell-quasiquotes) . @@ -77,26 +79,26 @@ alex , happy build-depends: - aeson >=1.4.7.1 && <1.5.6 - , array >=0.5.4.0 && <0.5.5 + aeson >=1.4.7.1 + , array >=0.5.4.0 , base >=4.13.0.0 && <4.15 - , binary-parser >=0.5.6 && <0.6 - , bytestring >=0.10.10.0 && <0.10.13 - , bytestring-strict-builder >=0.4.5.3 && <0.4.6 - , contravariant >=1.5.2 && <1.5.4 - , mtl >=2.2.2 && <2.2.3 - , postgresql-binary >=0.12.2 && <0.12.4 - , postgresql-libpq >=0.9.4.2 && <0.9.5 - , scientific >=0.3.6.2 && <0.3.7 - , syb >=0.7.1 && <0.7.2 - , template-haskell >=2.15.0.0 && <2.17 - , text >=1.2.3.2 && <1.2.5 - , th-lift-instances >=0.1.17 && <0.1.19 - , time >=1.9.3 && <1.9.4 - , transformers >=0.5.6.2 && <0.5.7 - , uuid >=1.3.13 && <1.3.14 - , vector >=0.12.1.2 && <0.12.2 - , vector-sized >=1.4.1 && <1.4.4 + , binary-parser >=0.5.6 + , bytestring >=0.10.10.0 + , bytestring-strict-builder >=0.4.5.3 + , contravariant >=1.5.2 + , mtl >=2.2.2 + , postgresql-binary >=0.12.2 + , postgresql-libpq >=0.9.4.2 + , scientific >=0.3.6.2 + , syb >=0.7.1 + , template-haskell >=2.15.0.0 + , text >=1.2.3.2 + , th-lift-instances >=0.1.17 + , time >=1.9.3 + , transformers >=0.5.6.2 + , uuid >=1.3.13 + , vector >=0.12.1.2 + , vector-sized >=1.4.1 default-language: Haskell2010 test-suite tests @@ -117,31 +119,68 @@ alex , happy build-depends: - aeson >=1.4.7.1 && <1.5.6 - , array >=0.5.4.0 && <0.5.5 + aeson >=1.4.7.1 + , array >=0.5.4.0 , base >=4.13.0.0 && <4.15 - , binary-parser >=0.5.6 && <0.6 - , bytestring >=0.10.10.0 && <0.10.13 - , bytestring-strict-builder >=0.4.5.3 && <0.4.6 + , binary-parser >=0.5.6 + , bytestring >=0.10.10.0 + , bytestring-strict-builder >=0.4.5.3 , containers >=0.6.2.1 - , contravariant >=1.5.2 && <1.5.4 + , contravariant >=1.5.2 , generic-random <1.3.1 , hedgehog >=1.0.3 - , mtl >=2.2.2 && <2.2.3 - , postgresql-binary >=0.12.2 && <0.12.4 - , postgresql-libpq >=0.9.4.2 && <0.9.5 + , mtl >=2.2.2 + , postgresql-binary >=0.12.2 + , postgresql-libpq >=0.9.4.2 , preql - , scientific >=0.3.6.2 && <0.3.7 - , syb >=0.7.1 && <0.7.2 - , tasty >=1.2.3 && <1.4.1 + , scientific >=0.3.6.2 + , syb >=0.7.1 + , tasty >=1.2.3 , tasty-hedgehog >=1.0 - , tasty-hunit >=0.10.0 && <0.10.1 - , template-haskell >=2.15.0.0 && <2.17 - , text >=1.2.3.2 && <1.2.5 - , th-lift-instances >=0.1.17 && <0.1.19 - , time >=1.9.3 && <1.9.4 - , transformers >=0.5.6.2 && <0.5.7 - , uuid >=1.3.13 && <1.3.14 - , vector >=0.12.1.2 && <0.12.2 - , vector-sized >=1.4.1 && <1.4.4 + , tasty-hunit >=0.10.0 + , template-haskell >=2.15.0.0 + , text >=1.2.3.2 + , th-lift-instances >=0.1.17 + , time >=1.9.3 + , transformers >=0.5.6.2 + , uuid >=1.3.13 + , vector >=0.12.1.2 + , vector-sized >=1.4.1 + default-language: Haskell2010 + +benchmark pgbench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Paths_preql + hs-source-dirs: + benchmark + default-extensions: OverloadedStrings DataKinds + build-tools: + alex + , happy + build-depends: + aeson >=1.4.7.1 + , array >=0.5.4.0 + , base >=4.13.0.0 && <4.15 + , binary-parser >=0.5.6 + , bytestring >=0.10.10.0 + , bytestring-strict-builder >=0.4.5.3 + , contravariant >=1.5.2 + , criterion + , deepseq + , mtl >=2.2.2 + , postgresql-binary >=0.12.2 + , postgresql-libpq >=0.9.4.2 + , preql + , scientific >=0.3.6.2 + , syb >=0.7.1 + , template-haskell >=2.15.0.0 + , text >=1.2.3.2 + , th-lift-instances >=0.1.17 + , time >=1.9.3 + , transformers >=0.5.6.2 + , uuid >=1.3.13 + , vector >=0.12.1.2 + , vector-sized >=1.4.1 default-language: Haskell2010 diff --git a/src/Preql.hs b/src/Preql.hs --- a/src/Preql.hs +++ b/src/Preql.hs @@ -15,7 +15,7 @@ , module Preql.Wire ) where -import Preql.Effect -import Preql.QuasiQuoter.Raw.TH (sql) -import Preql.QuasiQuoter.Syntax.TH (select, validSql) -import Preql.Wire +import Preql.Effect +import Preql.QuasiQuoter.Raw.TH (sql) +import Preql.QuasiQuoter.Syntax.TH (select, validSql) +import Preql.Wire diff --git a/src/Preql/Effect.hs b/src/Preql/Effect.hs --- a/src/Preql/Effect.hs +++ b/src/Preql/Effect.hs @@ -85,6 +85,7 @@ query_ :: ToSql p => (Query 0, p) -> m () -- | Most larger applications will define an instance; this one is suitable to test out the library. +-- A safer version would use @MVar Connection@ to ensure only one thread using it. instance SQL (ReaderT Connection IO) where withConnection = (ask >>=) diff --git a/src/Preql/FromSql/Class.hs b/src/Preql/FromSql/Class.hs --- a/src/Preql/FromSql/Class.hs +++ b/src/Preql/FromSql/Class.hs @@ -8,8 +8,10 @@ import Preql.Wire.Errors import Preql.Wire.Internal +import Control.Exception (throwIO) import Control.Monad.Except -import Control.Monad.Trans.State +import Control.Monad.Trans.Reader (ask) +import Data.IORef (readIORef) import GHC.TypeNats import qualified BinaryParser as BP import qualified Data.Vector.Sized as VS @@ -33,27 +35,31 @@ -- | The number of columns read in decoding this type. type Width a :: Nat type Width a = 1 + {-# INLINE fromSql #-} fromSql :: RowDecoder (Width a) a default fromSql :: (FromSqlField a, Width a ~ 1) => RowDecoder (Width a) a fromSql = notNull fromSqlField -- | Construct a decoder for a single non-nullable column. +{-# INLINE notNull #-} notNull :: FieldDecoder a -> RowDecoder 1 a -notNull (FieldDecoder oid parser) = RowDecoder (VS.singleton oid) $ do +notNull (FieldDecoder oid parser) = {-# SCC "notNull" #-} RowDecoder (VS.singleton oid) $ do m_bs <- getNextValue case m_bs of Nothing -> throwLocated UnexpectedNull Just bs -> either (throwLocated . ParseFailure) pure (BP.run parser bs) -- | Construct a decoder for a single nullable column. +{-# INLINE nullable #-} nullable :: FieldDecoder a -> RowDecoder 1 (Maybe a) -nullable (FieldDecoder oid parser) = RowDecoder (VS.singleton oid) $ do +nullable (FieldDecoder oid parser) = {-# SCC "nullable" #-} RowDecoder (VS.singleton oid) $ do m_bs <- getNextValue case m_bs of Nothing -> return Nothing Just bs -> either (throwLocated . ParseFailure) (pure . Just) (BP.run parser bs) +{-# INLINE throwLocated #-} throwLocated :: UnlocatedFieldError -> InternalDecoder a -throwLocated fieldError = do - DecoderState{row = PQ.Row r, column = PQ.Col c} <- get - throwError (FieldError (fromIntegral r) (fromIntegral c) fieldError) +throwLocated fieldError = {-# SCC "throwLocated" #-} do + DecoderState{row = PQ.Row r, column = PQ.Col c} <- lift . readIORef =<< ask + lift $ throwIO (FieldError (fromIntegral r) (fromIntegral c) fieldError) diff --git a/src/Preql/FromSql/Instances.hs b/src/Preql/FromSql/Instances.hs --- a/src/Preql/FromSql/Instances.hs +++ b/src/Preql/FromSql/Instances.hs @@ -1,31 +1,31 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} module Preql.FromSql.Instances where -import Preql.FromSql.Class -import Preql.FromSql.TH -import Preql.Wire.Errors -import Preql.Wire.Internal (applyDecoder) -import Preql.Wire.Types +import Preql.FromSql.Class +import Preql.FromSql.TH +import Preql.Wire.Errors +import Preql.Wire.Internal (applyDecoder) +import Preql.Wire.Types -import Data.Int -import Data.Time (Day, TimeOfDay, UTCTime) -import Data.UUID (UUID) -import GHC.TypeNats -import Preql.Imports -import qualified BinaryParser as BP -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 BinaryParser as BP +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Time (Day, TimeOfDay, UTCTime) +import Data.UUID (UUID) +import qualified Database.PostgreSQL.LibPQ as PQ +import GHC.TypeNats import qualified PostgreSQL.Binary.Decoding as PGB +import Preql.Imports import qualified Preql.Wire.TypeInfo.Static as OID instance FromSqlField Bool where @@ -52,10 +52,9 @@ fromSqlField = FieldDecoder (Oid OID.float8Oid) PGB.float8 instance FromSql Double --- TODO does Postgres have a single-char type? Does it always return bpchar? --- instance FromSqlField Char where --- fromSqlField = FieldDecoder (Oid OID.charOid) PGB.char --- instance FromSql Char +instance FromSqlField Char where + fromSqlField = FieldDecoder (Oid OID.charOid) PGB.char +instance FromSql Char where fromSql = notNull fromSqlField instance FromSqlField String where fromSqlField = FieldDecoder (Oid OID.textOid) (T.unpack <$> PGB.text_strict) @@ -105,6 +104,10 @@ instance FromSqlField PQ.Oid where fromSqlField = PQ.Oid <$> FieldDecoder (Oid OID.oidOid) PGB.int instance FromSql PQ.Oid + +instance FromSqlField PgName where + fromSqlField = FieldDecoder (Oid OID.nameOid) (PgName <$> PGB.text_strict) +instance FromSql PgName where fromSql = notNull fromSqlField -- | If you want to encode some more specific Haskell type via JSON, -- it is more efficient to use 'fromSqlJsonField' rather than this diff --git a/src/Preql/FromSql/TH.hs b/src/Preql/FromSql/TH.hs --- a/src/Preql/FromSql/TH.hs +++ b/src/Preql/FromSql/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -- | Construct FromSql instances @@ -14,8 +15,10 @@ deriveFromSqlTuple :: Int -> Q [Dec] deriveFromSqlTuple n = do names <- traverse newName (take n alphabet) - let tuple = foldl AppT (TupleT n) (map VarT names) - return [fromSqlDecl names tuple (tupleDataName n) n] + let + fields = map VarT names + tuple = foldl AppT (TupleT n) fields + return [fromSqlDecl tuple (tupleDataName n) fields] deriveFromSql :: Name -> Q [Dec] deriveFromSql tyName = do @@ -24,14 +27,14 @@ TyConI (DataD _cxt typeN binders _kind constructors _deriving) -> let tyVars = map tyVarName binders - targetTy = foldl AppT (VarT typeN) (map VarT tyVars) - (conN, fieldCount) = case constructors of - [NormalC con elems] -> (con, length elems) - [RecC con fields] -> (con, length fields) - [InfixC _ con _] -> (con, 2) + targetTy = foldl AppT (ConT typeN) (map VarT tyVars) + (conN, fieldTypes) = case constructors of + [NormalC con elems] -> (con, [ty | (_, ty) <- elems]) + [RecC con fields] -> (con, [ty | (_, _, ty) <- fields]) + [InfixC (_, t1) con (_, t2)] -> (con, [t1, t2]) [_] -> error "deriveFromSql does not handle GADTs or constructors with class constraints" _ -> error "deriveFromSql does not handle sum types" - in return [fromSqlDecl tyVars targetTy conN fieldCount] + in return [fromSqlDecl targetTy conN fieldTypes] _ -> error ("deriveFromSql only handles type names, got: " ++ show tyName) tyVarName :: TyVarBndr -> Name @@ -40,19 +43,35 @@ KindedTV name _k -> name -fromSqlDecl :: [Name] -> Type -> Name -> Int -> Dec -fromSqlDecl tyVars targetTy constructor fieldCount = +fromSqlDecl :: Type -> Name -> [Type] -> Dec +fromSqlDecl targetTy constructor fields = InstanceD Nothing context instanceHead [TySynInstD width, method] where - context = [ ConT ''FromSql `AppT` VarT n | n <- tyVars ] + context = [ ConT ''FromSql `AppT` ty | ty <- fields, hasTyVar ty ] instanceHead = ConT ''FromSql `AppT` targetTy width = TySynEqn Nothing (ConT ''Width `AppT` targetTy) (foldl (\a b -> ConT ''(+) `AppT` a `AppT` b) (LitT (NumTyLit 0)) - [ ConT ''Width `AppT` VarT n | n <- tyVars ]) + [ ConT ''Width `AppT` ty | ty <- fields ]) method = ValD (VarP 'fromSql) (NormalB (foldl (\rowDecoder field -> InfixE (Just rowDecoder) (VarE 'applyDecoder) (Just field)) (VarE 'pureDecoder `AppE` ConE constructor) - (replicate fieldCount (VarE 'fromSql)))) + (replicate (length fields) (VarE 'fromSql)))) [] -- no where clause on the fromSql definition + +hasTyVar :: Type -> Bool +hasTyVar = \case + VarT _ -> True + ForallT _ _ ty -> hasTyVar ty +#if MIN_VERSION_template_haskell(2,16,0) + ForallVisT _ ty -> hasTyVar ty +#endif + AppT t1 t2 -> hasTyVar t1 || hasTyVar t2 + AppKindT ty _ -> hasTyVar ty + SigT ty _ -> hasTyVar ty + InfixT t1 _ t2 -> hasTyVar t1 || hasTyVar t2 + UInfixT t1 _ t2 -> hasTyVar t1 || hasTyVar t2 + ParensT ty -> hasTyVar ty + ImplicitParamT _ ty -> hasTyVar ty + _ -> False diff --git a/src/Preql/Wire/Decode.hs b/src/Preql/Wire/Decode.hs --- a/src/Preql/Wire/Decode.hs +++ b/src/Preql/Wire/Decode.hs @@ -11,7 +11,9 @@ import Preql.Wire.Errors import Preql.Wire.Internal +import Control.Exception (try) import Control.Monad.Except +import Data.IORef (newIORef) import GHC.TypeNats import Preql.Imports @@ -35,5 +37,6 @@ then return (Left (PgTypeMismatch mismatches)) else do (PQ.Row ntuples) <- liftIO $ PQ.ntuples result - fmap (first DecoderError) . runExceptT $ - V.generateM (fromIntegral ntuples) (decodeRow rd result . PQ.toRow) + ref <- newIORef (DecoderState result 0 0) + fmap (first DecoderError) . try $ + V.replicateM (fromIntegral ntuples) (decodeRow ref rd result) 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,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -13,8 +14,10 @@ import Preql.Wire.Errors +import Control.Monad.Except import Control.Monad.Trans.Except -import Control.Monad.Trans.State +import Control.Monad.Trans.Reader +import Data.IORef import Data.String (IsString) import GHC.TypeNats import Preql.Imports @@ -44,28 +47,42 @@ -- | Analogous to '<*>', @pureDecoder Constructor `applyDecoder` a -- `applyDecoder` b@ supplies two arguments to @Constructor@, from the -- 'RowDecoder' @a@ and @b@. +{-# INLINE applyDecoder #-} applyDecoder :: RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m+n) b applyDecoder (RowDecoder vm f) (RowDecoder vn a) = RowDecoder (vm VS.++ vn) (f <*> a) --- TODO can I use ValidationT instead of ExceptT, since I ensure Column is incremented before errors? -- | Internal because we need IO for the libpq FFI, but we promise not -- to do any IO besides decoding. We don't even make network calls to -- Postgres in @InternalDecoder@ -type InternalDecoder = StateT DecoderState (ExceptT FieldError IO) +type InternalDecoder = ReaderT (IORef DecoderState) IO data DecoderState = DecoderState - { result :: PQ.Result - , row :: PQ.Row - , column :: PQ.Column + { result :: !PQ.Result + , row :: !PQ.Row + , column :: !PQ.Column } deriving (Show, Eq) -decodeRow :: RowDecoder n a -> PQ.Result -> PQ.Row -> ExceptT FieldError IO a -decodeRow (RowDecoder _ parsers) result row = - evalStateT parsers (DecoderState result row 0) +{-# INLINE incrementColumn #-} +incrementColumn :: DecoderState -> DecoderState +incrementColumn s@DecoderState{column} = s { column = column + 1 } +{-# INLINE incrementRow #-} +incrementRow :: DecoderState -> DecoderState +incrementRow s = s { row = row s + 1, column = 0 } + +-- | Can throw FieldError +{-# INLINE decodeRow #-} +decodeRow :: IORef DecoderState -> RowDecoder n a -> PQ.Result -> IO a +decodeRow ref (RowDecoder _ parsers) result = {-# SCC "decodeRow" #-} do + result <- runReaderT parsers ref + modifyIORef ref incrementRow + return result + +{-# INLINE getNextValue #-} getNextValue :: InternalDecoder (Maybe ByteString) -getNextValue = do - s@DecoderState{..} <- get - put (s { column = column + 1 } :: DecoderState) - liftIO $ PQ.getvalue result row column +getNextValue = {-# SCC "getNextValue" #-} do + ref <- ask + DecoderState{..} <- lift $ readIORef ref + lift $ modifyIORef' ref incrementColumn + liftIO $ PQ.getvalue' result row column 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 @@ -2,8 +2,8 @@ module Preql.Wire.Query where import Preql.FromSql -import Preql.Wire.Errors import Preql.Wire.Decode +import Preql.Wire.Errors import Preql.Wire.Internal import Preql.Wire.ToSql @@ -11,6 +11,8 @@ import GHC.TypeNats import Preql.Imports +import Debug.Trace + import qualified Data.Text as T import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ @@ -22,8 +24,9 @@ -- TODO safer Connection type -- withMVar (connectionHandle conn) $ \connRaw -> do e_result <- execParams enc conn q params + traceEventIO "execParams > decodeVector" case e_result of - Left err -> return (Left err) + Left err -> return (Left err) Right rows -> decodeVector (lookupType conn) dec rows -- If there is no result, we don't need a Decoder @@ -59,7 +62,7 @@ m_msg <- liftIO $ PQ.errorMessage conn case m_msg of Just msg -> return (Left (decodeUtf8With lenientDecode msg)) - Nothing -> return (Left "No error message available") + Nothing -> return (Left "No error message available") lookupType :: PQ.Connection -> PgType -> IO (Either QueryError PQ.Oid) lookupType _ (Oid oid) = return (Right oid) @@ -70,8 +73,7 @@ Right (Just oid) -> return (Right oid) Right Nothing -> return (Left (ConnectionError ("No oid for: " <> name))) -data IsolationLevel - = ReadCommitted +data IsolationLevel = ReadCommitted | RepeatableRead | Serializable deriving (Show, Read, Eq, Ord, Enum, Bounded) 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 @@ -1,6 +1,13 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} + module Preql.Wire.Types where -import Data.Time (TimeOfDay, TimeZone) +import Data.Text (Text) +import Data.Time (TimeOfDay, TimeZone) data TimeTZ = TimeTZ !TimeOfDay !TimeZone deriving (Show, Eq) + +newtype PgName = PgName Text + deriving newtype (Show)