diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.6 (2021-07-31) + +- decode array types +- decode composite types with `Tuple` newtype +- cache OID lookups + # 0.5 (2021-01-10) - fix `deriveFromSql` which was completely unusable diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -7,6 +7,7 @@ module Main where import Preql +import Preql.Wire.Query (Connection(..), connectdbSharedCache) import qualified Preql.Wire.TypeInfo.Static as OID import Control.DeepSeq (NFData(..)) @@ -39,10 +40,10 @@ , PQ.Oid, PQ.Oid, PQ.Oid)) ] -connectDB :: IO PQ.Connection +connectDB :: IO Connection connectDB = do - conn <- PQ.connectdb =<< connectionString - status <- PQ.status conn + conn@(Connection rawConn _) <- connectdbSharedCache =<< connectionString + status <- PQ.status rawConn unless (status == PQ.ConnectionOk) (error "bad connection") return conn diff --git a/preql.cabal b/preql.cabal --- a/preql.cabal +++ b/preql.cabal @@ -1,13 +1,13 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.3. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: d56204964cb9b2be1a806f9feb77bc975fc037b053f1edf3b775c7dec9d2fed1 +-- hash: f4dbe72a66bc70347b232733521f1dc19162d6cae9eb9467c4f262693e91d5b2 name: preql -version: 0.5 +version: 0.6 synopsis: safe PostgreSQL queries using Quasiquoters description: Before you Post(gres)QL, preql. . @@ -48,6 +48,7 @@ Preql.FromSql.Class Preql.FromSql.Instances Preql.FromSql.TH + Preql.FromSql.Tuple Preql.Imports Preql.QuasiQuoter.Common Preql.QuasiQuoter.Raw.Lex @@ -60,7 +61,6 @@ Preql.QuasiQuoter.Syntax.Syntax Preql.QuasiQuoter.Syntax.TH Preql.Wire - Preql.Wire.Decode Preql.Wire.Errors Preql.Wire.Internal Preql.Wire.Orphans @@ -81,7 +81,7 @@ build-depends: aeson >=1.4.7.1 , array >=0.5.4.0 - , base >=4.13.0.0 && <4.15 + , base >=4.13.0.0 && <5.0 , binary-parser >=0.5.6 , bytestring >=0.10.10.0 , bytestring-strict-builder >=0.4.5.3 @@ -96,6 +96,7 @@ , th-lift-instances >=0.1.17 , time >=1.9.3 , transformers >=0.5.6.2 + , unordered-containers , uuid >=1.3.13 , vector >=0.12.1.2 , vector-sized >=1.4.1 @@ -121,13 +122,13 @@ build-depends: aeson >=1.4.7.1 , array >=0.5.4.0 - , base >=4.13.0.0 && <4.15 + , base >=4.13.0.0 && <5.0 , 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 - , generic-random <1.3.1 + , generic-random , hedgehog >=1.0.3 , mtl >=2.2.2 , postgresql-binary >=0.12.2 @@ -143,6 +144,7 @@ , th-lift-instances >=0.1.17 , time >=1.9.3 , transformers >=0.5.6.2 + , unordered-containers , uuid >=1.3.13 , vector >=0.12.1.2 , vector-sized >=1.4.1 @@ -162,7 +164,7 @@ build-depends: aeson >=1.4.7.1 , array >=0.5.4.0 - , base >=4.13.0.0 && <4.15 + , base >=4.13.0.0 && <5.0 , binary-parser >=0.5.6 , bytestring >=0.10.10.0 , bytestring-strict-builder >=0.4.5.3 @@ -180,6 +182,7 @@ , th-lift-instances >=0.1.17 , time >=1.9.3 , transformers >=0.5.6.2 + , unordered-containers , uuid >=1.3.13 , vector >=0.12.1.2 , vector-sized >=1.4.1 diff --git a/src/Preql.hs b/src/Preql.hs --- a/src/Preql.hs +++ b/src/Preql.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Description: Import this to start + +-- | Description: Import this + module Preql ( SQL(..), SqlQuery(..), sql, select, validSql , Transaction, Query diff --git a/src/Preql/Effect.hs b/src/Preql/Effect.hs --- a/src/Preql/Effect.hs +++ b/src/Preql/Effect.hs @@ -24,7 +24,6 @@ import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT) -import Database.PostgreSQL.LibPQ (Connection) import GHC.TypeNats import qualified Control.Monad.Trans.RWS.Lazy as L import qualified Control.Monad.Trans.RWS.Strict as S diff --git a/src/Preql/Effect/Internal.hs b/src/Preql/Effect/Internal.hs --- a/src/Preql/Effect/Internal.hs +++ b/src/Preql/Effect/Internal.hs @@ -10,7 +10,6 @@ import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Reader (ReaderT(..)) -import Database.PostgreSQL.LibPQ (Connection) -- | A Transaction can only contain SQL queries (and pure functions). newtype Transaction a = Transaction (ExceptT QueryError (ReaderT Connection IO) a) diff --git a/src/Preql/FromSql.hs b/src/Preql/FromSql.hs --- a/src/Preql/FromSql.hs +++ b/src/Preql/FromSql.hs @@ -4,4 +4,4 @@ import Preql.FromSql.Class as X import Preql.FromSql.Instances as X -import Preql.FromSql.TH as X +import Preql.FromSql.Tuple as X 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 @@ -21,8 +21,14 @@ -- Postgres type which can be decoded, and a parser from the binary -- representation of that type to the Haskell representation. data FieldDecoder a = FieldDecoder PgType (BP.BinaryParser a) - deriving Functor + deriving Functor +fieldParser :: FieldDecoder a -> BP.BinaryParser a +fieldParser (FieldDecoder _ parser) = parser + +-- | A type which can be decoded from a single SQL field. This is +-- mostly useful for defining what can be an element of an array or +-- 'Tuple'. class FromSqlField a where fromSqlField :: FieldDecoder a @@ -30,7 +36,8 @@ -- includes the canonical order of fields. -- -- The default (empty) instance works for any type with a --- 'FromSqlField' instance +-- 'FromSqlField' instance. This is convenient when you define your +-- own Postgres types, since they should be instances of both type classes. class FromSql a where -- | The number of columns read in decoding this type. type Width a :: Nat 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 @@ -5,67 +5,78 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Preql.FromSql.Instances where +module Preql.FromSql.Instances (fromSqlJsonField) 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.FromSql.Tuple +import Preql.Wire.Errors +import Preql.Wire.Internal (applyDecoder) +import Preql.Wire.Types -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 Data.Int +import Data.Time (Day, TimeOfDay, UTCTime) +import Data.UUID (UUID) +import Data.Vector (Vector) +import Database.PostgreSQL.LibPQ (Oid) +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 Data.Vector as V +import qualified Database.PostgreSQL.LibPQ as PQ import qualified PostgreSQL.Binary.Decoding as PGB -import Preql.Imports import qualified Preql.Wire.TypeInfo.Static as OID +-- We write @FromSql@ instances for each primitive type, rather than a single +-- @FromSqlField a => FromSql a@ in order to give better type errors. The +-- general instance above would overlap with every instance for a user-defined +-- type (for a table), and the error would suggest defining @FromSqlField@, +-- which is usually not the right answer. New field types (like enums) are much +-- less common than new tables, so this seems like a good tradeoff. + instance FromSqlField Bool where - fromSqlField = FieldDecoder (Oid OID.boolOid) PGB.bool + fromSqlField = FieldDecoder (Oid OID.boolOid OID.array_boolOid) PGB.bool instance FromSql Bool instance FromSqlField Int16 where - fromSqlField = FieldDecoder (Oid OID.int2Oid) PGB.int + fromSqlField = FieldDecoder (Oid OID.int2Oid OID.array_int2Oid) PGB.int instance FromSql Int16 instance FromSqlField Int32 where - fromSqlField = FieldDecoder (Oid OID.int4Oid) PGB.int + fromSqlField = FieldDecoder (Oid OID.int4Oid OID.array_int4Oid) PGB.int instance FromSql Int32 instance FromSqlField Int64 where - fromSqlField = FieldDecoder (Oid OID.int8Oid) PGB.int + fromSqlField = FieldDecoder (Oid OID.int8Oid OID.array_int8Oid) PGB.int instance FromSql Int64 instance FromSqlField Float where - fromSqlField = FieldDecoder (Oid OID.float4Oid) PGB.float4 + fromSqlField = FieldDecoder (Oid OID.float4Oid OID.array_float4Oid) PGB.float4 instance FromSql Float instance FromSqlField Double where - fromSqlField = FieldDecoder (Oid OID.float8Oid) PGB.float8 + fromSqlField = FieldDecoder (Oid OID.float8Oid OID.array_float8Oid) PGB.float8 instance FromSql Double instance FromSqlField Char where - fromSqlField = FieldDecoder (Oid OID.charOid) PGB.char + fromSqlField = FieldDecoder (Oid OID.charOid OID.array_charOid) PGB.char instance FromSql Char where fromSql = notNull fromSqlField -instance FromSqlField String where - fromSqlField = FieldDecoder (Oid OID.textOid) (T.unpack <$> PGB.text_strict) -instance FromSql String +instance {-# OVERLAPS #-} FromSqlField String where + fromSqlField = FieldDecoder (Oid OID.textOid OID.array_textOid) (T.unpack <$> PGB.text_strict) +instance {-# OVERLAPS #-} FromSql String instance FromSqlField Text where - fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_strict + fromSqlField = FieldDecoder (Oid OID.textOid OID.array_textOid) PGB.text_strict instance FromSql Text instance FromSqlField TL.Text where - fromSqlField = FieldDecoder (Oid OID.textOid) PGB.text_lazy + fromSqlField = FieldDecoder (Oid OID.textOid OID.array_textOid) PGB.text_lazy instance FromSql TL.Text -- | If you want to encode some more specific Haskell type via JSON, @@ -73,51 +84,51 @@ -- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this -- instance. instance FromSqlField ByteString where - fromSqlField = FieldDecoder (Oid OID.byteaOid) (BS.copy <$> BP.remainders) + fromSqlField = FieldDecoder (Oid OID.byteaOid OID.array_byteaOid) (BS.copy <$> BP.remainders) instance FromSql ByteString instance FromSqlField BSL.ByteString where - fromSqlField = FieldDecoder (Oid OID.byteaOid) (BSL.fromStrict . BS.copy <$> BP.remainders) + fromSqlField = FieldDecoder (Oid OID.byteaOid OID.array_byteaOid) (BSL.fromStrict . BS.copy <$> BP.remainders) instance FromSql BSL.ByteString -- TODO check for integer_datetimes setting instance FromSqlField UTCTime where - fromSqlField = FieldDecoder (Oid OID.timestamptzOid) PGB.timestamptz_int + fromSqlField = FieldDecoder (Oid OID.timestamptzOid OID.array_timestamptzOid) PGB.timestamptz_int instance FromSql UTCTime instance FromSqlField Day where - fromSqlField = FieldDecoder (Oid OID.dateOid) PGB.date + fromSqlField = FieldDecoder (Oid OID.dateOid OID.array_dateOid) PGB.date instance FromSql Day instance FromSqlField TimeOfDay where - fromSqlField = FieldDecoder (Oid OID.timeOid) PGB.time_int + fromSqlField = FieldDecoder (Oid OID.timeOid OID.array_timeOid) PGB.time_int instance FromSql TimeOfDay instance FromSqlField TimeTZ where - fromSqlField = FieldDecoder (Oid OID.timetzOid) (uncurry TimeTZ <$> PGB.timetz_int) + fromSqlField = FieldDecoder (Oid OID.timetzOid OID.array_timetzOid) (uncurry TimeTZ <$> PGB.timetz_int) instance FromSql TimeTZ instance FromSqlField UUID where - fromSqlField = FieldDecoder (Oid OID.uuidOid) PGB.uuid + fromSqlField = FieldDecoder (Oid OID.uuidOid OID.array_uuidOid) PGB.uuid instance FromSql UUID instance FromSqlField PQ.Oid where - fromSqlField = PQ.Oid <$> FieldDecoder (Oid OID.oidOid) PGB.int + fromSqlField = PQ.Oid <$> FieldDecoder (Oid OID.oidOid OID.array_oidOid) PGB.int instance FromSql PQ.Oid instance FromSqlField PgName where - fromSqlField = FieldDecoder (Oid OID.nameOid) (PgName <$> PGB.text_strict) + fromSqlField = FieldDecoder (Oid OID.nameOid OID.array_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 -- instance. instance FromSqlField JSON.Value where - fromSqlField = FieldDecoder (Oid OID.jsonbOid) PGB.jsonb_ast + fromSqlField = FieldDecoder (Oid OID.jsonbOid OID.array_jsonbOid) PGB.jsonb_ast instance FromSql JSON.Value fromSqlJsonField :: JSON.FromJSON a => FieldDecoder a -fromSqlJsonField = FieldDecoder (Oid OID.jsonbOid) +fromSqlJsonField = FieldDecoder (Oid OID.jsonbOid OID.array_jsonbOid) (PGB.jsonb_bytes (first T.pack . JSON.eitherDecode . BSL.fromStrict)) -- Overlappable so applications can write Maybe for multi-field domain types @@ -158,3 +169,86 @@ $(deriveFromSqlTuple 23) $(deriveFromSqlTuple 24) $(deriveFromSqlTuple 25) + +-- The array instances all overlap, because arrays can nest arbitrarily. +-- Unfortunately, this means a runtime error if an application programmer try to +-- nest arrays deeper than the instances that we provide. So we provide more +-- instances than we expect users to want. + +arrayDecoder :: FromSqlField a => (PGB.Array a -> PGB.Array b) -> FieldDecoder b +arrayDecoder dims = + FieldDecoder arrayType (PGB.array (dims (PGB.valueArray parser))) + where + FieldDecoder oneType parser = fromSqlField + arrayType = case oneType of + Oid _ oid -> Oid oid (PQ.Oid 0) + TypeName name -> TypeName ("_" <> name) + +dimV :: PGB.Array a -> PGB.Array (Vector a) +dimV = PGB.dimensionArray V.replicateM + +dimL :: PGB.Array a -> PGB.Array [a] +dimL = PGB.dimensionArray replicateM + +instance FromSqlField (Vector a) => FromSql (Vector a) +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField (Vector a) where + fromSqlField = arrayDecoder dimV + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField (Vector (Vector a)) where + fromSqlField = arrayDecoder (dimV . dimV) + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField (Vector (Vector (Vector a))) where + fromSqlField = arrayDecoder (dimV . dimV . dimV) + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField (Vector (Vector (Vector (Vector a)))) where + fromSqlField = arrayDecoder (dimV . dimV . dimV . dimV) + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField (Vector (Vector (Vector (Vector (Vector a))))) where + fromSqlField = arrayDecoder (dimV . dimV . dimV . dimV . dimV) + +instance FromSqlField [a] => FromSql [a] +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField [a] where + fromSqlField = arrayDecoder dimL + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField [[a]] where + fromSqlField = arrayDecoder (dimL . dimL) + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField [[[a]]] where + fromSqlField = arrayDecoder (dimL . dimL . dimL) + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField [[[[a]]]] where + fromSqlField = arrayDecoder (dimL . dimL . dimL . dimL) + +instance {-# OVERLAPPABLE #-} FromSqlField a => FromSqlField [[[[[a]]]]] where + fromSqlField = arrayDecoder (dimL . dimL . dimL . dimL . dimL) + +instance (FromSqlField a, FromSqlField b) => FromSqlField (Tuple (a, b)) where + fromSqlField = + let vc = valueComposite + in FieldDecoder (Oid OID.recordOid OID.array_recordOid) + (Tuple <$> composite 2 (pure (,) <*> vc fromSqlField <*> vc fromSqlField)) +instance (FromSqlField a, FromSqlField b) => FromSql (Tuple (a, b)) + +$(deriveFromSqlFieldTuple 3) +$(deriveFromSqlFieldTuple 4) +$(deriveFromSqlFieldTuple 5) +$(deriveFromSqlFieldTuple 6) +$(deriveFromSqlFieldTuple 7) +$(deriveFromSqlFieldTuple 8) +$(deriveFromSqlFieldTuple 9) +$(deriveFromSqlFieldTuple 10) +$(deriveFromSqlFieldTuple 11) +$(deriveFromSqlFieldTuple 12) +$(deriveFromSqlFieldTuple 13) +$(deriveFromSqlFieldTuple 14) +$(deriveFromSqlFieldTuple 15) +$(deriveFromSqlFieldTuple 16) +$(deriveFromSqlFieldTuple 17) +$(deriveFromSqlFieldTuple 18) +$(deriveFromSqlFieldTuple 19) +$(deriveFromSqlFieldTuple 20) +$(deriveFromSqlFieldTuple 21) +$(deriveFromSqlFieldTuple 22) +$(deriveFromSqlFieldTuple 23) +$(deriveFromSqlFieldTuple 24) +$(deriveFromSqlFieldTuple 25) 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 @@ -6,12 +6,17 @@ module Preql.FromSql.TH where import Preql.FromSql.Class +import Preql.FromSql.Tuple import Preql.QuasiQuoter.Common (alphabet) +import Preql.Wire.Errors (PgType(Oid)) import Preql.Wire.Internal +import qualified Preql.Wire.TypeInfo.Static as OID import GHC.TypeNats import Language.Haskell.TH +import qualified PostgreSQL.Binary.Decoding as PGB +-- | instance (FromSql a, FromSql b) => FromSql (a, b) deriveFromSqlTuple :: Int -> Q [Dec] deriveFromSqlTuple n = do names <- traverse newName (take n alphabet) @@ -20,6 +25,8 @@ tuple = foldl AppT (TupleT n) fields return [fromSqlDecl tuple (tupleDataName n) fields] +-- | derive a 'FromSql' instance for a record type +-- (field names are not required, but there must be only one constructor) deriveFromSql :: Name -> Q [Dec] deriveFromSql tyName = do info <- reify tyName @@ -37,10 +44,17 @@ in return [fromSqlDecl targetTy conN fieldTypes] _ -> error ("deriveFromSql only handles type names, got: " ++ show tyName) +#if MIN_VERSION_template_haskell(2,17,0) +tyVarName :: TyVarBndr () -> Name +tyVarName = \case + PlainTV name () -> name + KindedTV name () _k -> name +#else tyVarName :: TyVarBndr -> Name tyVarName = \case PlainTV name -> name KindedTV name _k -> name +#endif fromSqlDecl :: Type -> Name -> [Type] -> Dec @@ -59,6 +73,30 @@ (VarE 'pureDecoder `AppE` ConE constructor) (replicate (length fields) (VarE 'fromSql)))) [] -- no where clause on the fromSql definition + +-- instance (FromSqlField a, FromSqlField b) => FromSqlField (Tuple (a, b)) +-- instance (FromSqlField a, FromSqlField b) => FromSql (Tuple (a, b)) +deriveFromSqlFieldTuple :: Int -> Q [Dec] +deriveFromSqlFieldTuple n = do + names <- traverse newName (take n alphabet) + fieldOid <- [e| Oid OID.recordOid OID.array_recordOid |] + let + fields = map VarT names + tuple = ConT ''Tuple `AppT` foldl AppT (TupleT n) fields + context = [ ConT ''FromSqlField `AppT` ty | ty <- fields ] + width = TySynEqn Nothing (ConT ''Width `AppT` tuple) (LitT (NumTyLit 1)) + tupleSizeE = LitE (IntegerL (toInteger n)) + parser = VarE 'fmap `AppE` ConE 'Tuple `AppE` (VarE 'composite `AppE` tupleSizeE `AppE` foldl + (\parser field -> VarE '(<*>) `AppE` parser `AppE` field) + (VarE 'pure `AppE` ConE (tupleDataName n)) + (replicate n (VarE 'valueComposite `AppE` VarE 'fromSqlField))) + method = ValD + (VarP 'fromSqlField) + (NormalB (ConE 'FieldDecoder `AppE` fieldOid `AppE` parser)) + [] + return [ InstanceD Nothing context (ConT ''FromSqlField `AppT` tuple) [method] + , InstanceD Nothing context (ConT ''FromSql `AppT` tuple) [ ] ] + hasTyVar :: Type -> Bool hasTyVar = \case diff --git a/src/Preql/FromSql/Tuple.hs b/src/Preql/FromSql/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Preql/FromSql/Tuple.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Description: newtype to support FromSql instances for row types. + +module Preql.FromSql.Tuple where + +import Preql.FromSql.Class (FieldDecoder(..)) +import Preql.Wire.Errors (PgType(..)) + +import Control.Monad (unless) +import Data.Bits ((.|.), Bits, shiftL) +import Data.Int (Int32) +import qualified BinaryParser as BP +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Database.PostgreSQL.LibPQ as PQ + +-- | Wrapper for Postgres anonymous row types (sometimes called record +-- types), so instance resolution picks the right decoder. The useful +-- instances are for (Haskell) tuples. Postgres allows row types with +-- a single field, but the instances would overlap with those for +-- nested row types, so we do not provide them. +newtype Tuple r = Tuple r + deriving (Eq, Ord, Show) + +-- Unlike the same-named functions in PostgreSQL.Binary.Decoding, these check +-- the number of components and the OIDs of each component. + +-- | Helper for decoding composites +newtype Composite a = Composite (BP.BinaryParser a) + deriving newtype (Functor, Applicative) + +composite :: Int -> Composite a -> BP.BinaryParser a +composite n (Composite parser) = do + size <- intOfSize 4 + unless (size == n) (BP.failure "composite has wrong size") + parser + +valueComposite :: FieldDecoder a -> Composite a +valueComposite (FieldDecoder pgType parser) = Composite $ do + case pgType of + -- For now, we only confirm statically-known OIDs. To do more, we'll need + -- to feed through the OID cache (not yet implemented) and the Connection + -- (which will be a problem if we ever implement lazy decoding) + -- Statically-known OIDs seems like a reasonable compromise for now, until + -- other parts of the design stabilize. + Oid (PQ.Oid expected) _ -> do + actual <- intOfSize 4 + unless (actual == expected) (BP.failure $ "OID in composite expected=" <> showt expected <> " actual=" <> showt actual) + TypeName _ -> BP.unitOfSize 4 -- TODO check cache, maybe query DB + onContent parser >>= + maybe (BP.failure "unexpected null") pure + where showt = T.pack . show + +{-# INLINE intOfSize #-} +intOfSize :: (Integral a, Bits a) => Int -> BP.BinaryParser a +intOfSize x = + fmap (BS.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0) (BP.bytesOfSize x) + +{-# INLINABLE onContent #-} +onContent :: BP.BinaryParser a -> BP.BinaryParser ( Maybe a ) +onContent decoder = do + size :: Int32 <- intOfSize 4 + case size of + (-1) -> pure Nothing + n -> fmap Just (BP.sized (fromIntegral n) decoder) diff --git a/src/Preql/Wire.hs b/src/Preql/Wire.hs --- a/src/Preql/Wire.hs +++ b/src/Preql/Wire.hs @@ -11,12 +11,12 @@ , ToSql(..), ToSqlField -- * Errors , QueryError(..), FieldError(..), UnlocatedFieldError(..), TypeMismatch(..) + , Tuple(..) , module X) where -import Preql.Wire.Decode as X 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 -import Preql.Wire.Query as X (IsolationLevel(..)) -import Preql.FromSql.Class as X +import Preql.Wire.Query as X (Connection, IsolationLevel(..), decodeVector) +import Preql.FromSql as X diff --git a/src/Preql/Wire/Decode.hs b/src/Preql/Wire/Decode.hs deleted file mode 100644 --- a/src/Preql/Wire/Decode.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Decoding values from Postgres wire format to Haskell. - -module Preql.Wire.Decode where - -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 - -import qualified Data.Vector as V -import qualified Data.Vector.Sized as VS -import qualified Database.PostgreSQL.LibPQ as PQ - -decodeVector :: KnownNat n => - (PgType -> IO (Either QueryError PQ.Oid)) -> RowDecoder n a -> PQ.Result -> IO (Either QueryError (Vector a)) -decodeVector lookupType rd@(RowDecoder pgtypes _parsers) result = do - mismatches <- fmap (catMaybes . VS.toList) $ for (VS.zip (VS.enumFromN 0) pgtypes) $ \(column@(PQ.Col cint), expected) -> do - actual <- PQ.ftype result column - e_expectedOid <- lookupType expected - case e_expectedOid of - Right oid | actual == oid -> return Nothing - _ -> do - m_name <- liftIO $ PQ.fname result column - let columnName = decodeUtf8With lenientDecode <$> m_name - return $ Just (TypeMismatch{column = fromIntegral cint, ..}) - if not (null mismatches) - then return (Left (PgTypeMismatch mismatches)) - else do - (PQ.Row ntuples) <- liftIO $ PQ.ntuples result - ref <- newIORef (DecoderState result 0 0) - fmap (first DecoderError) . try $ - V.replicateM (fromIntegral ntuples) (decodeRow ref rd result) diff --git a/src/Preql/Wire/Errors.hs b/src/Preql/Wire/Errors.hs --- a/src/Preql/Wire/Errors.hs +++ b/src/Preql/Wire/Errors.hs @@ -27,7 +27,7 @@ instance Exception FieldError $(deriveJSON defaultOptions ''FieldError) -data PgType = Oid PQ.Oid -- ^ A Postgres type with a known ID +data PgType = Oid PQ.Oid PQ.Oid -- ^ A Postgres type with a known ID, and the matching array ID | TypeName Text -- ^ A Postgres type which we will need to lookup by name deriving (Eq, Show, Typeable) $(deriveJSON defaultOptions ''PgType) 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,45 +1,78 @@ +-- | Description: Send queries, decode results, look up OID for a known type name + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} module Preql.Wire.Query where import Preql.FromSql -import Preql.Wire.Decode import Preql.Wire.Errors import Preql.Wire.Internal import Preql.Wire.ToSql +import Control.Exception (try) import Control.Monad +import Control.Monad.Except +import Data.IORef import GHC.TypeNats import Preql.Imports +import System.IO.Unsafe (unsafePerformIO) import Debug.Trace +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Vector as V +import qualified Data.Vector.Sized as VS import qualified Database.PostgreSQL.LibPQ as PQ +-- Cache of OIDs by type name + +type TypeCache = IORef (HM.HashMap Text PQ.Oid) + +-- | We make the type cache part of the Connection to offer the option of +-- per-Connection (or striped) caches. It's also reasonable to share a single +-- cache for an entire multi-threaded program; the @IORef@ supports this usage. +data Connection = Connection + { rawConnection :: !PQ.Connection + , typeCache :: !TypeCache + } + +connectdbSharedCache :: ByteString -> IO Connection +connectdbSharedCache str = Connection <$> PQ.connectdb str <*> pure globalCache + +connectdbNewCache :: ByteString -> IO Connection +connectdbNewCache str = Connection <$> PQ.connectdb str <*> newIORef mempty + +finish :: Connection -> IO () +finish (Connection conn _) = PQ.finish conn + +globalCache :: TypeCache +globalCache = unsafePerformIO (newIORef mempty) + +-- send queries, receiving results + queryWith :: KnownNat (Width r) => - RowEncoder p -> RowDecoder (Width r) r -> PQ.Connection -> + RowEncoder p -> RowDecoder (Width r) r -> Connection -> Query (Width r) -> p -> IO (Either QueryError (Vector r)) -queryWith enc dec conn (Query q) params = do - -- 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) - Right rows -> decodeVector (lookupType conn) dec rows +queryWith enc dec conn@(Connection pqConn cache) (Query q) params = do + e_result <- execParams enc pqConn q params + traceEventIO "execParams > decodeVector" + case e_result of + Left err -> return (Left err) + Right rows -> decodeVector conn dec rows -- If there is no result, we don't need a Decoder -queryWith_ :: RowEncoder p -> PQ.Connection -> Query n -> p -> IO (Either QueryError ()) -queryWith_ enc conn (Query q) params = do +queryWith_ :: RowEncoder p -> Connection -> Query n -> p -> IO (Either QueryError ()) +queryWith_ enc (Connection conn _) (Query q) params = do e_result <- execParams enc conn q params return (void e_result) query :: (ToSql p, FromSql r, KnownNat (Width r)) => - PQ.Connection -> Query (Width r) -> p -> IO (Either QueryError (Vector r)) + Connection -> Query (Width r) -> p -> IO (Either QueryError (Vector r)) query = queryWith toSql fromSql -query_ :: ToSql p => PQ.Connection -> Query n -> p -> IO (Either QueryError ()) +query_ :: ToSql p => Connection -> Query n -> p -> IO (Either QueryError ()) query_ = queryWith_ toSql execParams :: RowEncoder p -> PQ.Connection -> ByteString -> p -> IO (Either QueryError PQ.Result) @@ -64,29 +97,77 @@ Just msg -> return (Left (decodeUtf8With lenientDecode msg)) Nothing -> return (Left "No error message available") -lookupType :: PQ.Connection -> PgType -> IO (Either QueryError PQ.Oid) -lookupType _ (Oid oid) = return (Right oid) -lookupType conn (TypeName name) = do - e_rows <- query conn "SELECT oid FROM pg_type WHERE typname = $1" name - case fmap (V.!? 0) e_rows of - Left e -> return (Left e) - Right (Just oid) -> return (Right oid) - Right Nothing -> return (Left (ConnectionError ("No oid for: " <> name))) +-- decoding +decodeVector :: KnownNat n => + Connection -> RowDecoder n a -> PQ.Result -> IO (Either QueryError (Vector a)) +decodeVector conn rd@(RowDecoder pgtypes _parsers) result = do + mismatches <- fmap (catMaybes . VS.toList) $ for (VS.zip (VS.enumFromN 0) pgtypes) $ \(column@(PQ.Col cint), expected) -> do + actual <- PQ.ftype result column + lookupResult <- lookupType conn expected + let mismatch = do + m_name <- liftIO $ PQ.fname result column + let columnName = decodeUtf8With lenientDecode <$> m_name + return $ Just (TypeMismatch{column = fromIntegral cint, ..}) + case lookupResult of + Cached oid | actual == oid -> return Nothing + FromDb oid | actual == oid -> return Nothing + Cached _ -> do -- recheck DB, in case type changed under us + e_oid <- lookupTypeIgnoreCache conn expected + case e_oid of + Right oid | actual == oid -> return Nothing + _ -> mismatch + _ -> mismatch + if not (null mismatches) + then return (Left (PgTypeMismatch mismatches)) + else do + (PQ.Row ntuples) <- liftIO $ PQ.ntuples result + ref <- newIORef (DecoderState result 0 0) + fmap (first DecoderError) . try $ + V.replicateM (fromIntegral ntuples) (decodeRow ref rd result) + where + +lookupType :: Connection -> PgType -> IO LookupResult +lookupType _ (Oid oid _) = return (FromDb oid) +lookupType conn@(Connection _ cacheRef) expected@(TypeName name) = do + cache <- readIORef cacheRef + case HM.lookup name cache of + Just oid -> return (Cached oid) + Nothing -> lookupTypeIgnoreCache conn expected + <&> either LookupError FromDb + +data LookupResult + = Cached PQ.Oid + | FromDb PQ.Oid + | LookupError QueryError + +lookupTypeIgnoreCache :: Connection -> PgType -> IO (Either QueryError PQ.Oid) +lookupTypeIgnoreCache _ (Oid oid _) = return (Right oid) +lookupTypeIgnoreCache conn@(Connection _ cacheRef) (TypeName name) = do + e_rows <- query conn "SELECT oid FROM pg_type WHERE typname = $1" name + case fmap (V.!? 0) e_rows of + Left e -> return (Left e) + Right (Just oid) -> do + atomicModifyIORef cacheRef (\cache -> (HM.insert name oid cache, ())) + return (Right oid) + Right Nothing -> return (Left (ConnectionError ("No oid for: " <> name))) + +-- transactions + data IsolationLevel = ReadCommitted | RepeatableRead | Serializable deriving (Show, Read, Eq, Ord, Enum, Bounded) -begin :: PQ.Connection -> IsolationLevel -> IO (Either QueryError ()) +begin :: Connection -> IsolationLevel -> IO (Either QueryError ()) begin conn level = query_ conn q () where q = case level of ReadCommitted -> "BEGIN ISOLATION LEVEL READ COMMITTED" RepeatableRead -> "BEGIN ISOLATION LEVEL REPEATABLE READ" Serializable -> "BEGIN ISOLATION LEVEL SERIALIZABLE" -commit :: PQ.Connection -> IO (Either QueryError ()) +commit :: Connection -> IO (Either QueryError ()) commit conn = query_ conn "COMMIT" () -rollback :: PQ.Connection -> IO (Either QueryError ()) +rollback :: Connection -> IO (Either QueryError ()) rollback conn = query_ conn "ROLLBACK" () diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -43,7 +43,7 @@ ] integration :: TestTree -integration = withResource initDB PQ.finish $ \db -> +integration = withResource initDB W.finish $ \db -> let query' :: (ToSql p, FromSql r, KnownNat (Width r)) => (Preql.Query (Width r), p) -> IO (Vector r) @@ -67,10 +67,10 @@ assertEqual "" [(1, "one")] (result :: Vector (Int32, T.Text)) ] -initDB :: HasCallStack => IO PQ.Connection +initDB :: HasCallStack => IO Connection initDB = do - conn <- PQ.connectdb =<< connectionString - status <- PQ.status conn + conn@(W.Connection rawConn _) <- W.connectdbSharedCache =<< connectionString + status <- PQ.status rawConn unless (status == PQ.ConnectionOk) (throwIO =<< badConnection conn) let query' q = either throwIO return =<< W.query_ conn q () query' "DROP TABLE IF EXISTS baz" diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs --- a/test/Test/Wire.hs +++ b/test/Test/Wire.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,14 +13,16 @@ import Control.Exception (Exception, bracket_, throwIO) import Control.Monad +import Data.Bits (shiftR) import Data.ByteString (ByteString) import Data.Either import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Time (Day, TimeOfDay, UTCTime) import Data.Vector (Vector) +import Data.Word (Word8) import GHC.TypeNats import System.Environment (lookupEnv) import Test.Tasty @@ -27,15 +30,19 @@ import Data.Time.Format.ISO8601 (iso8601ParseM) +import qualified BinaryParser as BP +import qualified Data.ByteString as BS import qualified Data.Text as T +import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as TL import qualified Data.UUID as UUID import qualified Database.PostgreSQL.LibPQ as PQ import qualified PostgreSQL.Binary.Decoding as PGB import qualified Preql.Wire.Query as W +import qualified Preql.Wire.TypeInfo.Static as OID wire :: TestTree -wire = withResource initDB PQ.finish $ \db -> testGroup "wire" $ +wire = withResource initDB W.finish $ \db -> testGroup "wire" $ let inTransaction desc body = testCase desc $ bracket_ (query_ "BEGIN TRANSACTION" ()) (query_ "ROLLBACK" ()) body @@ -194,13 +201,54 @@ query_ "create type foo as (bar bool, baz int)" () result <- query "select row(true, 1)::foo as foo" () assertEqual "" (Right [Foo True 1]) result + , inTransaction "anonymous row type (bool, int), row() syntax" $ do + result <- query "select row(true, 1)" () + assertEqual "" (Right [Tuple (True, 1::Int32)]) result + , inTransaction "anonymous row type (bool, int), tuple syntax" $ do + result <- query "select (true, 1)" () + assertEqual "" (Right [Tuple (True, 1::Int32)]) result + , inTransaction "longer derived row type" $ do + result <- query "select (true, 1, 'foo'::text)" () + assertEqual "" (Right [Tuple (True, 1::Int32, "foo"::Text)]) result + , inTransaction "nested row types" $ do + result <- query "select (true, row(1, 2))" () + assertEqual "" (Right [Tuple (True, Tuple (1::Int32, 2::Int32))]) result ] + , testGroup "array types" + [ inTransaction "text array" $ do + result <- query "select '{foo, bar, baz}'::text[]" () + assertEqual "" (Right [["foo", "bar", "baz"] :: [Text]]) result + , inTransaction "nested array" $ do + result <- query "select '{ {1, 2, 3}, {4, 5, 6} }'::int[][]" () + assertEqual "" (Right [ [[1, 2, 3], [4, 5, 6]]:: [[Int32]] ] ) result + , inTransaction "vector array" $ do + result <- query "select '{foo, bar, baz}'::text[]" () + assertEqual "" (Right [["foo", "bar", "baz"] :: Vector Text]) result + , inTransaction "array in row type" $ do + result <- query "select row(true, '{1, 2}'::int[])" () + -- assertEqual "" (Right [ Debug "" ]) result + assertEqual "" (Right [ Tuple (True, [1,2] :: [Int32]) ]) result + , inTransaction "array of row type" $ do + result <- query "select ARRAY[row(true, 'foo'::text), row(false, 'bar'::text)]" () + assertEqual "" (Right [ [Tuple (True, "foo"), Tuple (False, "bar")] :: [Tuple (Bool, Text)] ]) result + ] ] -initDB :: HasCallStack => IO PQ.Connection +newtype Debug = Debug ByteString + deriving Eq + +instance Show Debug where + show (Debug bs) = "text '" ++ T.unpack (decodeUtf8With T.lenientDecode bs) + ++ "' hex 0x" ++ concatMap hex (BS.unpack bs) + +instance FromSqlField Debug where + fromSqlField = FieldDecoder (Oid OID.recordOid OID.array_recordOid) (Debug <$> BP.remainders) +instance FromSql Debug + +initDB :: HasCallStack => IO Connection initDB = do - conn <- PQ.connectdb =<< connectionString - status <- PQ.status conn + conn@(W.Connection rawConn _) <- W.connectdbSharedCache =<< connectionString + status <- PQ.status rawConn 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)" () @@ -224,8 +272,8 @@ deriving (Show) instance Exception BadConnection -badConnection :: PQ.Connection -> IO BadConnection -badConnection c = do +badConnection :: Connection -> IO BadConnection +badConnection (W.Connection c _) = do status <- PQ.status c errorMessage <- fromMaybe "" <$> PQ.errorMessage c host <- fromMaybe "" <$> PQ.host c @@ -245,3 +293,25 @@ expt :: Num a => a -> Int64 -> a expt = (^) + +hex :: Word8 -> String +hex byte = [ nibble hi, nibble lo ] where + lo = byte `mod` 16 + hi = byte `shiftR` 4 + nibble = \case + 0 -> '0' + 1 -> '1' + 2 -> '2' + 3 -> '3' + 4 -> '4' + 5 -> '5' + 6 -> '6' + 7 -> '7' + 8 -> '8' + 9 -> '9' + 10 -> 'a' + 11 -> 'b' + 12 -> 'c' + 13 -> 'd' + 14 -> 'e' + 15 -> 'f'