packages feed

preql 0.5 → 0.6

raw patch · 17 files changed

+466/−141 lines, 17 filesdep +unordered-containersdep ~basedep ~generic-random

Dependencies added: unordered-containers

Dependency ranges changed: base, generic-random

Files

CHANGELOG.md view
@@ -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
benchmark/Bench.hs view
@@ -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
preql.cabal view
@@ -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
src/Preql.hs view
@@ -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
src/Preql/Effect.hs view
@@ -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
src/Preql/Effect/Internal.hs view
@@ -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)
src/Preql/FromSql.hs view
@@ -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
src/Preql/FromSql/Class.hs view
@@ -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
src/Preql/FromSql/Instances.hs view
@@ -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)
src/Preql/FromSql/TH.hs view
@@ -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
+ src/Preql/FromSql/Tuple.hs view
@@ -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)
src/Preql/Wire.hs view
@@ -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
− src/Preql/Wire/Decode.hs 
@@ -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)
src/Preql/Wire/Errors.hs view
@@ -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)
src/Preql/Wire/Query.hs view
@@ -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" ()
test/Test.hs view
@@ -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"
test/Test/Wire.hs view
@@ -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'