preql 0.4 → 0.5
raw patch · 12 files changed
+284/−115 lines, 12 filesdep +criteriondep +deepseqdep ~aesondep ~arraydep ~binary-parser
Dependencies added: criterion, deepseq
Dependency ranges changed: aeson, array, binary-parser, bytestring, bytestring-strict-builder, contravariant, mtl, postgresql-binary, postgresql-libpq, scientific, syb, tasty, tasty-hunit, template-haskell, text, th-lift-instances, time, transformers, uuid, vector, vector-sized
Files
- CHANGELOG.md +6/−0
- benchmark/Bench.hs +66/−0
- preql.cabal +85/−46
- src/Preql.hs +4/−4
- src/Preql/Effect.hs +1/−0
- src/Preql/FromSql/Class.hs +12/−6
- src/Preql/FromSql/Instances.hs +28/−25
- src/Preql/FromSql/TH.hs +32/−13
- src/Preql/Wire/Decode.hs +5/−2
- src/Preql/Wire/Internal.hs +30/−13
- src/Preql/Wire/Query.hs +7/−5
- src/Preql/Wire/Types.hs +8/−1
CHANGELOG.md view
@@ -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
+ benchmark/Bench.hs view
@@ -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
preql.cabal view
@@ -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
src/Preql.hs view
@@ -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
src/Preql/Effect.hs view
@@ -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 >>=)
src/Preql/FromSql/Class.hs view
@@ -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)
src/Preql/FromSql/Instances.hs view
@@ -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
src/Preql/FromSql/TH.hs view
@@ -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
src/Preql/Wire/Decode.hs view
@@ -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)
src/Preql/Wire/Internal.hs view
@@ -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
src/Preql/Wire/Query.hs view
@@ -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)
src/Preql/Wire/Types.hs view
@@ -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)