squeal-postgresql 0.7.0.1 → 0.8.0.0

raw patch · 36 files changed

+1152/−557 lines, 36 filesdep −unliftio-poolPVP ok

version bump matches the API change (PVP)

Dependencies removed: unliftio-pool

API changes (from Hackage documentation)

Files

• bench/Gauge/DBHelpers.hs +2/−1
• squeal-postgresql.cabal +4/−4
• src/Squeal/PostgreSQL.hs +5/−0
• src/Squeal/PostgreSQL/Definition/Index.hs +2/−2
• src/Squeal/PostgreSQL/Expression.hs +2/−0
• src/Squeal/PostgreSQL/Expression/Aggregate.hs +9/−0
• src/Squeal/PostgreSQL/Expression/Comparison.hs +2/−2
• src/Squeal/PostgreSQL/Expression/Composite.hs +1/−1
• src/Squeal/PostgreSQL/Expression/Inline.hs +6/−0
• src/Squeal/PostgreSQL/Expression/Json.hs +22/−0
• src/Squeal/PostgreSQL/Expression/Null.hs +11/−0
• src/Squeal/PostgreSQL/Expression/Subquery.hs +4/−2
• src/Squeal/PostgreSQL/Expression/Text.hs +23/−0
• src/Squeal/PostgreSQL/Expression/Time.hs +52/−1
• src/Squeal/PostgreSQL/Expression/Window.hs +16/−0
• src/Squeal/PostgreSQL/Query.hs +6/−6
• src/Squeal/PostgreSQL/Query/Table.hs +3/−2
• src/Squeal/PostgreSQL/Query/With.hs +83/−3
• src/Squeal/PostgreSQL/Session.hs +84/−67
• src/Squeal/PostgreSQL/Session/Decode.hs +71/−36
• src/Squeal/PostgreSQL/Session/Encode.hs +62/−37
• src/Squeal/PostgreSQL/Session/Exception.hs +16/−12
• src/Squeal/PostgreSQL/Session/Migration.hs +2/−2
• src/Squeal/PostgreSQL/Session/Monad.hs +7/−12
• src/Squeal/PostgreSQL/Session/Oid.hs +21/−11
• src/Squeal/PostgreSQL/Session/Pool.hs +15/−9
• src/Squeal/PostgreSQL/Session/Result.hs +122/−124
• src/Squeal/PostgreSQL/Session/Statement.hs +1/−23
• src/Squeal/PostgreSQL/Session/Transaction.hs +94/−191
• src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs +299/−0
• src/Squeal/PostgreSQL/Type.hs +3/−2
• src/Squeal/PostgreSQL/Type/List.hs +47/−0
• src/Squeal/PostgreSQL/Type/PG.hs +8/−0
• src/Squeal/PostgreSQL/Type/Schema.hs +39/−0
• test/Property.hs +2/−2
• test/Spec.hs +6/−5

@@ -22,6 +22,7 @@ import           GHC.Generics                   ( Generic ) import           Test.QuickCheck import           Squeal.PostgreSQL+import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe import           Control.DeepSeq -- Project imports import           Gauge.Schema                   ( Schemas )@@ -36,7 +37,7 @@ runDbErr   :: SquealPool -> PQ Schemas Schemas IO b -> IO (Either SquealException b) runDbErr pool session = do-  liftIO . runUsingConnPool pool $ trySqueal (transactionally_ session)+  liftIO . runUsingConnPool pool $ trySqueal (Unsafe.transactionally_ session)  runDbWithPool :: SquealPool -> PQ Schemas Schemas IO b -> IO b runDbWithPool pool session = do

@@ -1,5 +1,5 @@ name: squeal-postgresql-version: 0.7.0.1+version: 0.8.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal@@ -8,7 +8,7 @@ license-file: LICENSE author: Eitan Chatav maintainer: eitan.chatav@gmail.com-copyright: Copyright (c) 2017 Morphism, LLC+copyright: Copyright (c) 2021 Morphism, LLC category: Database build-type: Simple cabal-version: >=1.18@@ -79,6 +79,7 @@     Squeal.PostgreSQL.Session.Result     Squeal.PostgreSQL.Session.Statement     Squeal.PostgreSQL.Session.Transaction+    Squeal.PostgreSQL.Session.Transaction.Unsafe     Squeal.PostgreSQL.Type     Squeal.PostgreSQL.Type.Alias     Squeal.PostgreSQL.Type.List@@ -112,7 +113,6 @@     , transformers >= 0.5.6.2     , transformers-base >= 0.4.5.2     , unliftio >= 0.2.12.1-    , unliftio-pool >= 0.2.1.1     , uuid-types >= 1.0.3     , vector >= 0.12.1.2 @@ -131,7 +131,7 @@   default-language: Haskell2010   type: exitcode-stdio-1.0   hs-source-dirs: test-  ghc-options: -Wall+  ghc-options: -Wall    main-is: Property.hs   build-depends:       base >= 4.12.0.0 && < 5.0

@@ -190,6 +190,11 @@     & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]++This should get you up and running with Squeal. Once you're writing more complicated+queries and need a deeper understanding of Squeal's types and how everything+fits together, check out the <https://github.com/morphismtech/squeal/blob/dev/squeal-core-concepts-handbook.md Core Concepts Handbook>+in the toplevel of Squeal's Git repo. -} module Squeal.PostgreSQL   ( module X

@@ -173,14 +173,14 @@ -- DROP INDEX "ix"; dropIndex   :: (Has sch db schema, KnownSymbol ix)-  => QualifiedAlias sch ix -- index alias+  => QualifiedAlias sch ix -- ^ index alias   -> Definition db (Alter sch (DropSchemum ix 'Index schema) db) dropIndex ix = UnsafeDefinition $ "DROP INDEX" <+> renderSQL ix <> ";"  -- | Drop an index if it exists. dropIndexIfExists   :: (Has sch db schema, KnownSymbol ix)-  => QualifiedAlias sch ix -- index alias+  => QualifiedAlias sch ix -- ^ index alias   -> Definition db (Alter sch (DropSchemumIfExists ix 'Index schema) db) dropIndexIfExists ix = UnsafeDefinition $   "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"

@@ -585,6 +585,8 @@   (@>) = unsafeBinaryOp "@>"   (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)   (<@) = unsafeBinaryOp "<@"+infix 4 @>+infix 4 <@ instance PGSubset 'PGjsonb instance PGSubset 'PGtsquery instance PGSubset ('PGvararray ty)

@@ -19,7 +19,9 @@   , OverloadedStrings   , PatternSynonyms   , PolyKinds+  , ScopedTypeVariables   , StandaloneDeriving+  , TypeApplications   , TypeFamilies   , TypeOperators   , UndecidableInstances@@ -428,6 +430,13 @@   , aggregateFilter :: [Condition 'Ungrouped lat with db params from]     -- ^ `filterWhere`   }++instance (HasUnique tab (Join from lat) row, Has col row ty)+  => IsLabel col (AggregateArg '[ty] lat with db params from) where+    fromLabel = All (fromLabel @col)+instance (Has tab (Join from lat) row, Has col row ty)+  => IsQualified tab col (AggregateArg '[ty] lat with db params from) where+    tab ! col = All (tab ! col)  instance SOP.SListI xs => RenderSQL (AggregateArg xs lat with db params from) where   renderSQL = \case

@@ -150,7 +150,7 @@ >>> printSQL $ true `isDistinctFrom` null_ (TRUE IS DISTINCT FROM NULL) -}-isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+isDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"  {- | equal, treating null like an ordinary value@@ -158,7 +158,7 @@ >>> printSQL $ true `isNotDistinctFrom` null_ (TRUE IS NOT DISTINCT FROM NULL) -}-isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)+isNotDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"  {- | is true

@@ -65,7 +65,7 @@ -- | A row constructor on all columns in a table expression. rowStar   :: Has tab from row-  => Alias tab+  => Alias tab -- ^ intermediate table   -> Expression grp lat with db params from (null ('PGcomposite row)) rowStar tab = UnsafeExpression $ "ROW" <>   parenthesized (renderSQL tab <> ".*")

@@ -39,6 +39,9 @@ import Data.ByteString.Lazy (toStrict) import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec) import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.Coerce (coerce)+import Data.Functor.Const (Const(Const))+import Data.Functor.Constant (Constant(Constant)) import Data.Int (Int16, Int32, Int64) import Data.Kind (Type) import Data.Scientific (Scientific)@@ -168,6 +171,9 @@     . UnsafeExpression     . escapeQuotedText     . getFixChar+instance Inline x => Inline (Const x tag) where inline = inline @x . coerce+instance Inline x => Inline (SOP.K x tag) where inline = inline @x . coerce+instance Inline x => Inline (Constant x tag) where inline = inline @x . coerce instance Inline DiffTime where   inline dt =     let

@@ -61,7 +61,9 @@   , jsonEach   , jsonbEach   , jsonEachText+  , jsonArrayElementsText   , jsonbEachText+  , jsonbArrayElementsText   , jsonObjectKeys   , jsonbObjectKeys   , JsonPopulateFunction@@ -361,6 +363,16 @@     ("json_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]) jsonEachText = unsafeSetFunction "json_each_text" +{- | Returns a set of text values from a JSON array++>>> printSQL (select Star (from (jsonArrayElementsText (inline (Json (toJSON ["monkey", "pony", "bear"] ))))))+SELECT * FROM json_array_elements_text(('["monkey","pony","bear"]' :: json))+-}+jsonArrayElementsText+  :: null 'PGjson -|->+    ("json_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext])+jsonArrayElementsText = unsafeSetFunction "json_array_elements_text"+ {- | Expands the outermost binary JSON object into a set of key/value pairs.  >>> printSQL (select Star (from (jsonbEachText (inline (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))@@ -390,6 +402,16 @@   :: null 'PGjsonb -|->     ("jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext]) jsonbObjectKeys = unsafeSetFunction "jsonb_object_keys"++{- | Returns a set of text values from a binary JSON array++>>> printSQL (select Star (from (jsonbArrayElementsText (inline (Jsonb (toJSON ["red", "green", "cyan"] ))))))+SELECT * FROM jsonb_array_elements_text(('["red","green","cyan"]' :: jsonb))+-}+jsonbArrayElementsText+  :: null 'PGjsonb -|->+    ("jsonb_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext])+jsonbArrayElementsText = unsafeSetFunction "jsonb_array_elements_text"  -- | Build rows from Json types. type JsonPopulateFunction fun json

@@ -10,8 +10,10 @@  {-# LANGUAGE     DataKinds+  , KindSignatures   , OverloadedStrings   , RankNTypes+  , TypeFamilies   , TypeOperators #-} @@ -27,6 +29,7 @@   , isNotNull   , matchNull   , nullIf+  , CombineNullity   ) where  import Squeal.PostgreSQL.Expression@@ -121,3 +124,11 @@ -} nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty nullIf = unsafeFunctionN "NULLIF"++{-| Make the return type of the type family `NotNull` if both arguments are,+   or `Null` otherwise.+-}+type family CombineNullity+      (lhs :: PGType -> NullType) (rhs :: PGType -> NullType) :: PGType -> NullType where+  CombineNullity 'NotNull 'NotNull = 'NotNull+  CombineNullity _ _ = 'Null

@@ -103,7 +103,8 @@ in_   :: Expression grp lat with db params from ty -- ^ expression   -> [Expression grp lat with db params from ty]-  -> Expression grp lat with db params from (null 'PGbool)+  -> Expression grp lat with db params from ('Null 'PGbool)+_ `in_` [] = false expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"   <+> parenthesized (commaSeparated (renderSQL <$> exprs)) @@ -117,6 +118,7 @@ notIn   :: Expression grp lat with db params from ty -- ^ expression   -> [Expression grp lat with db params from ty]-  -> Expression grp lat with db params from (null 'PGbool)+  -> Expression grp lat with db params from ('Null 'PGbool)+_ `notIn` [] = true expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"   <+> parenthesized (commaSeparated (renderSQL <$> exprs))

@@ -11,6 +11,8 @@ {-# LANGUAGE     DataKinds   , OverloadedStrings+  , RankNTypes+  , ScopedTypeVariables   , TypeOperators #-} @@ -21,6 +23,8 @@   , charLength   , like   , ilike+  , replace+  , strpos   ) where  import Squeal.PostgreSQL.Expression@@ -63,3 +67,22 @@ -- ((E'abc' :: text) ILIKE (E'a%' :: text)) ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) ilike = unsafeBinaryOp "ILIKE"++-- | Determines the location of the substring match using the `strpos`+-- function. Returns the 1-based index of the first match, if no+-- match exists the function returns (0).+--+-- >>> printSQL $ strpos ("string" *: "substring")+-- strpos((E'string' :: text), (E'substring' :: text))+strpos+  :: '[null 'PGtext, null 'PGtext] ---> null 'PGint4+strpos = unsafeFunctionN "strpos"++-- | Over the string in the first argument, replace all occurrences of+-- the second argument with the third and return the modified string.+--+-- >>> printSQL $ replace ("string" :* "from" *: "to")+-- replace((E'string' :: text), (E'from' :: text), (E'to' :: text))+replace+  :: '[ null 'PGtext, null 'PGtext, null 'PGtext ] ---> null 'PGtext+replace = unsafeFunctionN "replace"

@@ -17,7 +17,9 @@   , OverloadedStrings   , PolyKinds   , RankNTypes+  , TypeFamilies   , TypeOperators+  , UndecidableInstances #-}  module Squeal.PostgreSQL.Expression.Time@@ -27,6 +29,7 @@   , currentDate   , currentTime   , currentTimestamp+  , dateTrunc   , localTime   , localTimestamp   , now@@ -34,6 +37,8 @@   , makeTime   , makeTimestamp   , makeTimestamptz+  , atTimeZone+  , PGAtTimeZone     -- * Interval   , interval_   , TimeUnit (..)@@ -41,12 +46,14 @@  import Data.Fixed import Data.String+import GHC.TypeLits  import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP  import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Type.Schema  -- $setup@@ -127,6 +134,49 @@ makeTimestamptz = unsafeFunctionN "make_timestamptz"  {-|+Truncate a timestamp with the specified precision++>>> printSQL $ dateTrunc Quarter (makeTimestamp (2010 :* 5 :* 6 :* 14 :* 45 *: 11.4))+date_trunc('quarter', make_timestamp((2010 :: int4), (5 :: int4), (6 :: int4), (14 :: int4), (45 :: int4), (11.4 :: float8)))+-}+dateTrunc+  :: time `In` '[ 'PGtimestamp, 'PGtimestamptz ]+  => TimeUnit -> null time --> null time+dateTrunc tUnit args = unsafeFunctionN "date_trunc" (timeUnitExpr *: args)+  where+  timeUnitExpr :: forall grp lat with db params from null0.+    Expression grp lat with db params from (null0 'PGtext)+  timeUnitExpr = UnsafeExpression . singleQuotedUtf8 . renderSQL $ tUnit++-- | Calculate the return time type of the `atTimeZone` `Operator`.+type family PGAtTimeZone ty where+  PGAtTimeZone 'PGtimestamptz = 'PGtimestamp+  PGAtTimeZone 'PGtimestamp = 'PGtimestamptz+  PGAtTimeZone 'PGtimetz = 'PGtimetz+  PGAtTimeZone pg = TypeError+    ( 'Text "Squeal type error: AT TIME ZONE cannot be applied to "+      ':<>: 'ShowType pg )++{-|+Convert a timestamp, timestamp with time zone, or time of day with timezone to a different timezone using an interval offset or specific timezone denoted by text. When using the interval offset, the interval duration must be less than one day or 24 hours.++>>> printSQL $ (makeTimestamp (2009 :* 7 :* 22 :* 19 :* 45 *: 11.4)) `atTimeZone` (interval_ 8 Hours)+(make_timestamp((2009 :: int4), (7 :: int4), (22 :: int4), (19 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (INTERVAL '8.000 hours'))++>>> :{+ let+   timezone :: Expr (null 'PGtext)+   timezone = "EST"+ in printSQL $ (makeTimestamptz (2015 :* 9 :* 15 :* 4 :* 45 *: 11.4)) `atTimeZone` timezone+:}+(make_timestamptz((2015 :: int4), (9 :: int4), (15 :: int4), (4 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (E'EST' :: text))+-}+atTimeZone+  :: zone `In` '[ 'PGtext, 'PGinterval]+  => Operator (null time) (null zone) (null (PGAtTimeZone time))+atTimeZone = unsafeBinaryOp "AT TIME ZONE"++{-| Affine space operations on time types. -} class TimeOp time diff | time -> diff where@@ -167,7 +217,7 @@  -- | A `TimeUnit` to use in `interval_` construction. data TimeUnit-  = Years | Months | Weeks | Days+  = Years | Quarter | Months | Weeks | Days   | Hours | Minutes | Seconds   | Microseconds | Milliseconds   | Decades | Centuries | Millennia@@ -177,6 +227,7 @@ instance RenderSQL TimeUnit where   renderSQL = \case     Years -> "years"+    Quarter -> "quarter"     Months -> "months"     Weeks -> "weeks"     Days -> "days"

@@ -22,7 +22,10 @@   , OverloadedStrings   , PatternSynonyms   , RankNTypes+  , ScopedTypeVariables+  , TypeApplications   , TypeOperators+  , UndecidableInstances #-}  module Squeal.PostgreSQL.Expression.Window@@ -177,6 +180,19 @@     , windowFilter :: [Condition grp lat with db params from]       -- ^ `filterWhere`     } deriving stock (GHC.Generic)++instance (HasUnique tab (Join from lat) row, Has col row ty)+  => IsLabel col (WindowArg 'Ungrouped '[ty] lat with db params from) where+    fromLabel = Window (fromLabel @col)+instance (Has tab (Join from lat) row, Has col row ty)+  => IsQualified tab col (WindowArg 'Ungrouped '[ty] lat with db params from) where+    tab ! col = Window (tab ! col)+instance (HasUnique tab (Join from lat) row, Has col row ty, GroupedBy tab col bys)+  => IsLabel col (WindowArg ('Grouped bys) '[ty] lat with db params from) where+    fromLabel = Window (fromLabel @col)+instance (Has tab (Join from lat) row, Has col row ty, GroupedBy tab col bys)+  => IsQualified tab col (WindowArg ('Grouped bys) '[ty] lat with db params from) where+    tab ! col = Window (tab ! col)  instance SOP.SListI args   => RenderSQL (WindowArg grp args lat with db params from) where

@@ -353,7 +353,7 @@ -- | The results of two queries can be combined using the set operation -- `union`. Duplicate rows are eliminated. union-  :: Query lat with db params columns+  :: Query lat with db params columns -- ^   -> Query lat with db params columns   -> Query lat with db params columns q1 `union` q2 = UnsafeQuery $@@ -364,7 +364,7 @@ -- | The results of two queries can be combined using the set operation -- `unionAll`, the disjoint union. Duplicate rows are retained. unionAll-  :: Query lat with db params columns+  :: Query lat with db params columns -- ^   -> Query lat with db params columns   -> Query lat with db params columns q1 `unionAll` q2 = UnsafeQuery $@@ -375,7 +375,7 @@ -- | The results of two queries can be combined using the set operation -- `intersect`, the intersection. Duplicate rows are eliminated. intersect-  :: Query lat with db params columns+  :: Query lat with db params columns -- ^   -> Query lat with db params columns   -> Query lat with db params columns q1 `intersect` q2 = UnsafeQuery $@@ -386,7 +386,7 @@ -- | The results of two queries can be combined using the set operation -- `intersectAll`, the intersection. Duplicate rows are retained. intersectAll-  :: Query lat with db params columns+  :: Query lat with db params columns -- ^   -> Query lat with db params columns   -> Query lat with db params columns q1 `intersectAll` q2 = UnsafeQuery $@@ -397,7 +397,7 @@ -- | The results of two queries can be combined using the set operation -- `except`, the set difference. Duplicate rows are eliminated. except-  :: Query lat with db params columns+  :: Query lat with db params columns -- ^   -> Query lat with db params columns   -> Query lat with db params columns q1 `except` q2 = UnsafeQuery $@@ -408,7 +408,7 @@ -- | The results of two queries can be combined using the set operation -- `exceptAll`, the set difference. Duplicate rows are retained. exceptAll-  :: Query lat with db params columns+  :: Query lat with db params columns -- ^   -> Query lat with db params columns   -> Query lat with db params columns q1 `exceptAll` q2 = UnsafeQuery $

@@ -230,11 +230,12 @@ Similarly, a table is processed as `NoWait` if that is specified in any of the clauses affecting it. Otherwise, it is processed as `SkipLocked` if that is specified in any of the clauses affecting it.+Further, a `LockingClause` cannot be added to a grouped table expression. -} lockRows   :: LockingClause from -- ^ row-level lock-  -> TableExpression grp lat with db params from-  -> TableExpression grp lat with db params from+  -> TableExpression 'Ungrouped lat with db params from+  -> TableExpression 'Ungrouped lat with db params from lockRows lck tab = tab {lockingClauses = lck : lockingClauses tab}  {-----------------------------------------

@@ -36,11 +36,17 @@     With (..)   , CommonTableExpression (..)   , withRecursive+  , Materialization (..)+  , materialized+  , notMaterialized   ) where  import Data.Quiver.Functor import GHC.TypeLits +import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP+ import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Type.List@@ -134,6 +140,23 @@     <+> "AS" <+> parenthesized (renderSQL recursive)     <+> renderSQL query +-- | Whether the contents of the WITH clause are materialized.+-- If a WITH query is non-recursive and side-effect-free (that is, it is a SELECT containing no volatile functions) then it can be folded into the parent query, allowing joint optimization of the two query levels.+--+-- Note: Use of `Materialized` or `NotMaterialized` requires PostgreSQL version 12 or higher. For earlier versions, use `DefaultMaterialization` which in those earlier versions of PostgreSQL behaves as `Materialized`. PostgreSQL 12 both changes the default behavior as well as adds options for customizing the materialization behavior.+data Materialization =+  DefaultMaterialization -- ^ By default, folding happens if the parent query references the WITH query just once, but not if it references the WITH query more than once. Note: this is the behavior in PostgreSQL 12+. In PostgreSQL 11 and earlier, all CTEs are materialized.+  | Materialized -- ^ You can override that decision by specifying MATERIALIZED to force separate calculation of the WITH query. Requires PostgreSQL 12+.+  | NotMaterialized -- ^ or by specifying NOT MATERIALIZED to force it to be merged into the parent query. Requires PostgreSQL 12+.+  deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance SOP.Generic Materialization+instance SOP.HasDatatypeInfo Materialization+instance RenderSQL Materialization where+  renderSQL = \case+    DefaultMaterialization -> ""+    Materialized -> "MATERIALIZED"+    NotMaterialized -> "NOT MATERIALIZED"+ -- | A `CommonTableExpression` is an auxiliary statement in a `with` clause. data CommonTableExpression statement   (db :: SchemasType)@@ -143,6 +166,8 @@   CommonTableExpression     :: Aliased (statement with db params) (cte ::: common)     -- ^ aliased statement+    -> Materialization+    -- ^ materialization of the CTE output     -> CommonTableExpression statement db params with (cte ::: common ': with) instance   ( KnownSymbol cte@@ -150,7 +175,7 @@   ) => Aliasable cte     (statement with db params common)     (CommonTableExpression statement db params with with1) where-      statement `as` cte = CommonTableExpression (statement `as` cte)+      statement `as` cte = CommonTableExpression (statement `as` cte) DefaultMaterialization instance   ( KnownSymbol cte   , with1 ~ (cte ::: common ': with)@@ -161,5 +186,60 @@  instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL   (CommonTableExpression statement db params with0 with1) where-    renderSQL (CommonTableExpression (statement `As` cte)) =-      renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)+    renderSQL (CommonTableExpression (statement `As` cte) materialization) =+      renderSQL cte+        <+> "AS"+        <+> renderSQL materialization+        <> case materialization of+              DefaultMaterialization -> ""+              _ -> " "+        <> parenthesized (renderSQL statement)++{- | Force separate calculation of the WITH query.++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+  qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+  qry = with (+    materialized (select Star (from (table #tab)) `as` #cte1) :>>+    select Star (from (common #cte1)) `as` #cte2+    ) (select Star (from (common #cte2)))+in printSQL qry+:}+WITH "cte1" AS MATERIALIZED (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done`.++Requires PostgreSQL 12 or higher.+-}+materialized+  :: Aliased (statement with db params) (cte ::: common) -- ^ CTE+  -> CommonTableExpression statement db params with (cte ::: common ': with)+materialized stmt = CommonTableExpression stmt Materialized++{- | Force the WITH query to be merged into the parent query.++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+  qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+  qry = with (+    select Star (from (table #tab)) `as` #cte1 :>>+    notMaterialized (select Star (from (common #cte1)) `as` #cte2) :>>+    Done+    ) (select Star (from (common #cte2)))+in printSQL qry+:}+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS NOT MATERIALIZED (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done` to finish the `Path`.++Requires PostgreSQL 12 or higher.+-}+notMaterialized+  :: Aliased (statement with db params) (cte ::: common) -- ^ CTE+  -> CommonTableExpression statement db params with (cte ::: common ': with)+notMaterialized stmt = CommonTableExpression stmt NotMaterialized

@@ -39,12 +39,12 @@  import Control.Category import Control.Monad.Base (MonadBase(..))-import Control.Monad.Catch (MonadCatch(..), MonadThrow(..), MonadMask(..))+import Control.Monad.Catch import Control.Monad.Except import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..))-import UnliftIO (MonadUnliftIO (..), bracket,  throwIO)+import UnliftIO (MonadUnliftIO(..)) import Data.ByteString (ByteString) import Data.Foldable import Data.Functor ((<&>))@@ -123,32 +123,32 @@  instance IndexedMonadTransPQ PQ where -  define (UnsafeDefinition q) = PQ $ \ (K conn) -> do-    resultMaybe <- liftIO $ LibPQ.exec conn q+  define (UnsafeDefinition q) = PQ $ \ (K conn) -> liftIO $ do+    resultMaybe <-  LibPQ.exec conn q     case resultMaybe of-      Nothing -> throwIO $ ConnectionException "LibPQ.exec"+      Nothing -> throwM $ ConnectionException "LibPQ.exec"       Just result -> K <$> okResult_ result  instance (MonadIO io, db0 ~ db, db1 ~ db) => MonadPQ db (PQ db0 db1 io) where    executeParams (Manipulation encode decode (UnsafeManipulation q)) x =-    PQ $ \ kconn@(K conn) -> do+    PQ $ \ kconn@(K conn) -> liftIO $ do       let         formatParam           :: forall param. OidOfNull db param           => K (Maybe Encoding.Encoding) param-          -> io (K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param)+          -> IO (K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param)         formatParam (K maybeEncoding) = do-          oid <- liftIO $ runReaderT (oidOfNull @db @param) kconn+          oid <- runReaderT (oidOfNull @db @param) kconn           return . K $ maybeEncoding <&> \encoding ->             (oid, encodingBytes encoding, LibPQ.Binary)-      encodedParams <- liftIO $ runReaderT (runEncodeParams encode x) kconn+      encodedParams <- runReaderT (runEncodeParams encode x) kconn       formattedParams <- hcollapse <$>         hctraverse' (Proxy @(OidOfNull db)) formatParam encodedParams-      resultMaybe <- liftIO $+      resultMaybe <-         LibPQ.execParams conn (q <> ";") formattedParams LibPQ.Binary       case resultMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.execParams"+        Nothing -> throwM $ ConnectionException "LibPQ.execParams"         Just result -> do           okResult_ result           return $ K (Result decode result)@@ -158,70 +158,88 @@   executePrepared (Manipulation encode decode (UnsafeManipulation q :: Manipulation '[] db params row)) list =     PQ $ \ kconn@(K conn) -> liftIO $ do       let+         temp = "temporary_statement"+         oidOfParam :: forall p. OidOfNull db p => (IO :.: K LibPQ.Oid) p         oidOfParam = Comp $ K <$> runReaderT (oidOfNull @db @p) kconn         oidsOfParams :: NP (IO :.: K LibPQ.Oid) params         oidsOfParams = hcpure (Proxy @(OidOfNull db)) oidOfParam-      oids <- hcollapse <$> hsequence' oidsOfParams-      prepResultMaybe <- LibPQ.prepare conn temp (q <> ";") (Just oids)-      case prepResultMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.prepare"-        Just prepResult -> okResult_ prepResult-      results <- for list $ \ params -> do-        encodedParams <- runReaderT (runEncodeParams encode params) kconn-        let-          formatParam encoding = (encodingBytes encoding, LibPQ.Binary)-          formattedParams =-            [ formatParam <$> maybeParam-            | maybeParam <- hcollapse encodedParams-            ]-        resultMaybe <--          LibPQ.execPrepared conn temp formattedParams LibPQ.Binary-        case resultMaybe of-          Nothing -> throwIO $ ConnectionException "LibPQ.execPrepared"-          Just result -> do-            okResult_ result-            return $ Result decode result-      deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")-      case deallocResultMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.exec"-        Just deallocResult -> okResult_ deallocResult-      return (K results)++        prepare = do+          oids <- hcollapse <$> hsequence' oidsOfParams+          prepResultMaybe <- LibPQ.prepare conn temp (q <> ";") (Just oids)+          case prepResultMaybe of+            Nothing -> throwM $ ConnectionException "LibPQ.prepare"+            Just prepResult -> okResult_ prepResult++        deallocate = do+          deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")+          case deallocResultMaybe of+            Nothing -> throwM $ ConnectionException "LibPQ.exec"+            Just deallocResult -> okResult_ deallocResult++        execPrepared = for list $ \ params -> do+          encodedParams <- runReaderT (runEncodeParams encode params) kconn+          let+            formatParam encoding = (encodingBytes encoding, LibPQ.Binary)+            formattedParams =+              [ formatParam <$> maybeParam+              | maybeParam <- hcollapse encodedParams+              ]+          resultMaybe <-+            LibPQ.execPrepared conn temp formattedParams LibPQ.Binary+          case resultMaybe of+            Nothing -> throwM $ ConnectionException "LibPQ.execPrepared"+            Just result -> do+              okResult_ result+              return $ Result decode result++      liftIO (K <$> bracket_ prepare deallocate execPrepared)+   executePrepared (Query encode decode q) list =     executePrepared (Manipulation encode decode (queryStatement q)) list    executePrepared_ (Manipulation encode _ (UnsafeManipulation q :: Manipulation '[] db params row)) list =-    PQ $ \ kconn@(K conn) -> liftIO $ do+    PQ $ \ kconn@(K conn) -> do       let+         temp = "temporary_statement"+         oidOfParam :: forall p. OidOfNull db p => (IO :.: K LibPQ.Oid) p         oidOfParam = Comp $ K <$> runReaderT (oidOfNull @db @p) kconn         oidsOfParams :: NP (IO :.: K LibPQ.Oid) params         oidsOfParams = hcpure (Proxy @(OidOfNull db)) oidOfParam-      oids <- hcollapse <$> hsequence' oidsOfParams-      prepResultMaybe <- LibPQ.prepare conn temp (q <> ";") (Just oids)-      case prepResultMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.prepare"-        Just prepResult -> okResult_ prepResult-      for_ list $ \ params -> do-        encodedParams <- runReaderT (runEncodeParams encode params) kconn-        let-          formatParam encoding = (encodingBytes encoding, LibPQ.Binary)-          formattedParams =-            [ formatParam <$> maybeParam-            | maybeParam <- hcollapse encodedParams-            ]-        resultMaybe <--          LibPQ.execPrepared conn temp formattedParams LibPQ.Binary-        case resultMaybe of-          Nothing -> throwIO $ ConnectionException "LibPQ.execPrepared"-          Just result -> okResult_ result-      deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")-      case deallocResultMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.exec"-        Just deallocResult -> okResult_ deallocResult-      return (K ())++        prepare = do+          oids <- hcollapse <$> hsequence' oidsOfParams+          prepResultMaybe <- LibPQ.prepare conn temp (q <> ";") (Just oids)+          case prepResultMaybe of+            Nothing -> throwM $ ConnectionException "LibPQ.prepare"+            Just prepResult -> okResult_ prepResult++        deallocate = do+          deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")+          case deallocResultMaybe of+            Nothing -> throwM $ ConnectionException "LibPQ.exec"+            Just deallocResult -> okResult_ deallocResult++        execPrepared_ = for_ list $ \ params -> do+          encodedParams <- runReaderT (runEncodeParams encode params) kconn+          let+            formatParam encoding = (encodingBytes encoding, LibPQ.Binary)+            formattedParams =+              [ formatParam <$> maybeParam+              | maybeParam <- hcollapse encodedParams+              ]+          resultMaybe <-+            LibPQ.execPrepared conn temp formattedParams LibPQ.Binary+          case resultMaybe of+            Nothing -> throwM $ ConnectionException "LibPQ.execPrepared"+            Just result -> okResult_ result++      liftIO (K <$> bracket_ prepare deallocate execPrepared_)+   executePrepared_ (Query encode decode q) list =     executePrepared_ (Manipulation encode decode (queryStatement q)) list @@ -320,13 +338,12 @@ -- | Do `connectdb` and `finish` before and after a computation. withConnection   :: forall db0 db1 io x-   . MonadUnliftIO io+   . (MonadIO io, MonadMask io)   => ByteString   -> PQ db0 db1 io x   -> io x-withConnection connString action = do-  K x <- bracket (connectdb connString) finish (unPQ action)-  return x+withConnection connString action =+  unK <$> bracket (connectdb connString) finish (unPQ action)  okResult_ :: MonadIO io => LibPQ.Result -> io () okResult_ result = liftIO $ do@@ -337,9 +354,9 @@     _ -> do       stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate       case stateCodeMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.resultErrorField"+        Nothing -> throwM $ ConnectionException "LibPQ.resultErrorField"         Just stateCode -> do           msgMaybe <- LibPQ.resultErrorMessage result           case msgMaybe of-            Nothing -> throwIO $ ConnectionException "LibPQ.resultErrorMessage"-            Just msg -> throwIO . SQLException $ SQLState status stateCode msg+            Nothing -> throwM $ ConnectionException "LibPQ.resultErrorMessage"+            Just msg -> throwM . SQLException $ SQLState status stateCode msg

@@ -10,6 +10,7 @@  {-# LANGUAGE     AllowAmbiguousTypes+  , CPP   , DataKinds   , DerivingStrategies   , FlexibleContexts@@ -25,6 +26,7 @@   , TypeFamilies   , TypeOperators   , UndecidableInstances+  , UndecidableSuperClasses #-}  module Squeal.PostgreSQL.Session.Decode@@ -37,7 +39,7 @@   , DecodeRow (..)   , decodeRow   , runDecodeRow-  , genericRow+  , GenericRow (..)   , appendRows   , consRow     -- * Decoding Classes@@ -52,12 +54,17 @@ import Control.Applicative import Control.Arrow import Control.Monad+#if MIN_VERSION_base(4,13,0)+#else import Control.Monad.Fail+#endif import Control.Monad.Except import Control.Monad.Reader-import Control.Monad.State+import Control.Monad.State.Strict import Control.Monad.Trans.Maybe import Data.Bits+import Data.Coerce (coerce)+import Data.Functor.Constant (Constant(Constant)) import Data.Int (Int16, Int32, Int64) import Data.Kind import Data.Scientific (Scientific)@@ -118,7 +125,7 @@ -} rowValue   :: (PG y ~ 'PGcomposite row, SOP.SListI row)-  => DecodeRow row y+  => DecodeRow row y -- ^ fields   -> StateT Strict.ByteString (Except Strict.Text) y rowValue decoder = devalue $   let@@ -229,6 +236,12 @@         , "."         ]       Just x -> pure x+instance FromPG x => FromPG (Const x tag) where+  fromPG = coerce $ fromPG @x+instance FromPG x => FromPG (SOP.K x tag) where+  fromPG = coerce $ fromPG @x+instance FromPG x => FromPG (Constant x tag) where+  fromPG = coerce $ fromPG @x instance FromPG Day where   fromPG = devalue date instance FromPG TimeOfDay where@@ -491,52 +504,74 @@   :: (SOP.NP (SOP.K (Maybe Strict.ByteString)) row -> Either Strict.Text y)   -> DecodeRow row y decodeRow dec = DecodeRow . ReaderT $ liftEither . dec-instance {-# OVERLAPPING #-} FromValue ty y+instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty y)   => IsLabel fld (DecodeRow (fld ::: ty ': row) y) where-    fromLabel = decodeRow $ \(SOP.K b SOP.:* _) ->-      fromValue @ty b+    fromLabel = decodeRow $ \(SOP.K b SOP.:* _) -> do+      let+        flderr = mconcat+          [ "field name: "+          , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "+          ]+      left (flderr <>) $ fromValue @ty b instance {-# OVERLAPPABLE #-} IsLabel fld (DecodeRow row y)   => IsLabel fld (DecodeRow (field ': row) y) where     fromLabel = decodeRow $ \(_ SOP.:* bs) ->       runDecodeRow (fromLabel @fld) bs-instance {-# OVERLAPPING #-} FromValue ty (Maybe y)+instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty (Maybe y))   => IsLabel fld (MaybeT (DecodeRow (fld ::: ty ': row)) y) where-    fromLabel = MaybeT . decodeRow $ \(SOP.K b SOP.:* _) ->-      fromValue @ty b+    fromLabel = MaybeT . decodeRow $ \(SOP.K b SOP.:* _) -> do+      let+        flderr = mconcat+          [ "field name: "+          , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "+          ]+      left (flderr <>) $ fromValue @ty b instance {-# OVERLAPPABLE #-} IsLabel fld (MaybeT (DecodeRow row) y)   => IsLabel fld (MaybeT (DecodeRow (field ': row)) y) where     fromLabel = MaybeT . decodeRow $ \(_ SOP.:* bs) ->       runDecodeRow (runMaybeT (fromLabel @fld)) bs -{- | Row decoder for `SOP.Generic` records.-->>> import qualified GHC.Generics as GHC->>> import qualified Generics.SOP as SOP->>> data Two = Two {frst :: Int16, scnd :: String} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)->>> :{-let-  decode :: DecodeRow '[ "frst" ::: 'NotNull 'PGint2, "scnd" ::: 'NotNull 'PGtext] Two-  decode = genericRow-in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil)-:}-Right (Two {frst = 2, scnd = "two"})--}-genericRow :: forall row y ys.+-- | A `GenericRow` constraint to ensure that a Haskell type+-- is a record type,+-- has a `RowPG`,+-- and all its fields and can be decoded from corresponding Postgres fields.+class   ( SOP.IsRecord y ys+  , row ~ RowPG y   , SOP.AllZip FromField row ys-  ) => DecodeRow row y-genericRow-  = DecodeRow-  . ReaderT-  $ fmap SOP.fromRecord-  . SOP.hsequence'-  . SOP.htrans (SOP.Proxy @FromField) (SOP.Comp . runField)-runField-  :: forall ty y. FromField ty y-  => SOP.K (Maybe Strict.ByteString) ty-  -> Except Strict.Text (SOP.P y)-runField = liftEither . fromField @ty . SOP.unK+  ) => GenericRow row y ys where+  {- | Row decoder for `SOP.Generic` records. +  >>> import qualified GHC.Generics as GHC+  >>> import qualified Generics.SOP as SOP+  >>> data Two = Two {frst :: Int16, scnd :: String} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)+  >>> :{+  let+    decode :: DecodeRow '[ "frst" ::: 'NotNull 'PGint2, "scnd" ::: 'NotNull 'PGtext] Two+    decode = genericRow+  in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil)+  :}+  Right (Two {frst = 2, scnd = "two"})+  -}+  genericRow :: DecodeRow row y+instance+  ( row ~ RowPG y+  , SOP.IsRecord y ys+  , SOP.AllZip FromField row ys+  ) => GenericRow row y ys where+  genericRow+    = DecodeRow+    . ReaderT+    $ fmap SOP.fromRecord+    . SOP.hsequence'+    . SOP.htrans (SOP.Proxy @FromField) (SOP.Comp . runField)+    where+      runField+        :: forall ty z. FromField ty z+        => SOP.K (Maybe Strict.ByteString) ty+        -> Except Strict.Text (SOP.P z)+      runField = liftEither . fromField @ty . SOP.unK+ {- | >>> :{ data Dir = North | East | South | West@@ -552,7 +587,7 @@ -} enumValue   :: (SOP.All KnownSymbol labels, PG y ~ 'PGenum labels)-  => NP (SOP.K y) labels+  => NP (SOP.K y) labels -- ^ labels   -> StateT Strict.ByteString (Except Strict.Text) y enumValue = devalue . enum . labels   where

@@ -24,12 +24,13 @@   , TypeFamilies   , TypeOperators   , UndecidableInstances+  , UndecidableSuperClasses #-}  module Squeal.PostgreSQL.Session.Encode   ( -- * Encode Parameters     EncodeParams (..)-  , genericParams+  , GenericParams (..)   , nilParams   , (.*)   , (*.)@@ -48,6 +49,9 @@ import Data.Bits import Data.ByteString as Strict (ByteString) import Data.ByteString.Lazy as Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Functor.Const (Const(Const))+import Data.Functor.Constant (Constant(Constant)) import Data.Functor.Contravariant import Data.Int (Int16, Int32, Int64) import Data.Kind@@ -122,6 +126,9 @@ instance ToPG db Lazy.ByteString where toPG = pure . bytea_lazy instance ToPG db (VarChar n) where toPG = pure . text_strict . getVarChar instance ToPG db (FixChar n) where toPG = pure . text_strict . getFixChar+instance ToPG db x => ToPG db (Const x tag) where toPG = toPG @db @x . coerce+instance ToPG db x => ToPG db (SOP.K x tag) where toPG = toPG @db @x . coerce+instance ToPG db x => ToPG db (Constant x tag) where toPG = toPG @db @x . coerce instance ToPG db Day where toPG = pure . date instance ToPG db TimeOfDay where toPG = pure . time_int instance ToPG db (TimeOfDay, TimeZone) where toPG = pure . timetz_int@@ -333,42 +340,56 @@ instance Contravariant (EncodeParams db tys) where   contramap f (EncodeParams g) = EncodeParams (g . f) -{- | Parameter encoding for `SOP.Generic` tuples and records.+-- | A `GenericParams` constraint to ensure that a Haskell type+-- is a product type,+-- has a `TuplePG`,+-- and all its terms have known Oids,+-- and can be encoded to corresponding Postgres types.+class+  ( SOP.IsProductType x xs+  , params ~ TuplePG x+  , SOP.All (OidOfNull db) params+  , SOP.AllZip (ToParam db) params xs+  ) => GenericParams db params x xs where+  {- | Parameter encoding for `SOP.Generic` tuples and records. ->>> import qualified GHC.Generics as GHC->>> import qualified Generics.SOP as SOP->>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic)->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"->>> :{-let-  encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two-  encode = genericParams-in runReaderT (runEncodeParams encode (Two 2 "two")) conn-:}-K (Just "\NUL\STX") :* K (Just "two") :* Nil+  >>> import qualified GHC.Generics as GHC+  >>> import qualified Generics.SOP as SOP+  >>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic)+  >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+  >>> :{+  let+    encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two+    encode = genericParams+  in runReaderT (runEncodeParams encode (Two 2 "two")) conn+  :}+  K (Just "\NUL\STX") :* K (Just "two") :* Nil ->>> :{-let-  encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] (Int16, String)-  encode = genericParams-in runReaderT (runEncodeParams encode (2, "two")) conn-:}-K (Just "\NUL\STX") :* K (Just "two") :* Nil+  >>> :{+  let+    encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] (Int16, String)+    encode = genericParams+  in runReaderT (runEncodeParams encode (2, "two")) conn+  :}+  K (Just "\NUL\STX") :* K (Just "two") :* Nil ->>> finish conn--}-genericParams :: forall db params x xs.-  ( SOP.IsProductType x xs+  >>> finish conn+  -}+  genericParams :: EncodeParams db params x+instance+  ( params ~ TuplePG x+  , SOP.All (OidOfNull db) params+  , SOP.IsProductType x xs   , SOP.AllZip (ToParam db) params xs-  ) => EncodeParams db params x-genericParams = EncodeParams-  $ hctransverse (SOP.Proxy @(ToParam db)) encodeNullParam-  . SOP.unZ . SOP.unSOP . SOP.from-  where-    encodeNullParam-      :: forall ty y. ToParam db ty y-      => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty)-    encodeNullParam = fmap SOP.K . toParam @db @ty . SOP.unI+  ) => GenericParams db params x xs where+  genericParams = EncodeParams+    $ hctransverse (SOP.Proxy @(ToParam db)) encodeNullParam+    . SOP.unZ . SOP.unSOP . SOP.from+    where+      encodeNullParam+        :: forall ty y. ToParam db ty y+        => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty)+      encodeNullParam = fmap SOP.K . toParam @db @ty . SOP.unI  -- | Encode 0 parameters. nilParams :: EncodeParams db '[] x@@ -390,7 +411,7 @@ >>> finish conn -} (.*)-  :: forall db x0 ty x tys. (ToParam db ty x0)+  :: forall db x0 ty x tys. (ToParam db ty x0, ty ~ NullPG x0)   => (x -> x0) -- ^ head   -> EncodeParams db tys x -- ^ tail   -> EncodeParams db (ty ': tys) x@@ -415,7 +436,11 @@ -} (*.)   :: forall db x x0 ty0 x1 ty1-   . (ToParam db ty0 x0, ToParam db ty1 x1)+   . ( ToParam db ty0 x0+     , ty0 ~ NullPG x0+     , ToParam db ty1 x1+     , ty1 ~ NullPG x1+     )   => (x -> x0) -- ^ second to last   -> (x -> x1) -- ^ last   -> EncodeParams db '[ty0, ty1] x@@ -436,8 +461,8 @@ >>> finish conn -} aParam-  :: forall db x. ToParam db (NullPG x) x-  => EncodeParams db '[NullPG x] x+  :: forall db x ty. (ToParam db ty x, ty ~ NullPG x)+  => EncodeParams db '[ty] x aParam = EncodeParams $   fmap (\param -> SOP.K param :* Nil) . toParam @db @(NullPG x) 

@@ -18,6 +18,7 @@   , pattern UniqueViolation   , pattern CheckViolation   , pattern SerializationFailure+  , pattern DeadlockDetected   , SQLState (..)   , LibPQ.ExecStatus (..)   , catchSqueal@@ -26,10 +27,9 @@   , throwSqueal   ) where -import Control.Exception (Exception)+import Control.Monad.Catch import Data.ByteString (ByteString) import Data.Text (Text)-import UnliftIO (MonadUnliftIO (..), catch, handle, try, throwIO)  import qualified Database.PostgreSQL.LibPQ as LibPQ @@ -71,26 +71,30 @@ pattern SerializationFailure :: ByteString -> SquealException pattern SerializationFailure msg =   SQLException (SQLState LibPQ.FatalError "40001" msg)+-- | A pattern for deadlock detection exceptions.+pattern DeadlockDetected :: ByteString -> SquealException+pattern DeadlockDetected msg =+  SQLException (SQLState LibPQ.FatalError "40P01" msg)  -- | Catch `SquealException`s. catchSqueal-  :: MonadUnliftIO io-  => io a-  -> (SquealException -> io a) -- ^ handler-  -> io a+  :: MonadCatch m+  => m a+  -> (SquealException -> m a) -- ^ handler+  -> m a catchSqueal = catch  -- | Handle `SquealException`s. handleSqueal-  :: MonadUnliftIO io-  => (SquealException -> io a) -- ^ handler-  -> io a -> io a+  :: MonadCatch m+  => (SquealException -> m a) -- ^ handler+  -> m a -> m a handleSqueal = handle  -- | `Either` return a `SquealException` or a result.-trySqueal :: MonadUnliftIO io => io a -> io (Either SquealException a)+trySqueal :: MonadCatch m => m a -> m (Either SquealException a) trySqueal = try  -- | Throw `SquealException`s.-throwSqueal :: MonadUnliftIO io => SquealException -> io a-throwSqueal = throwIO+throwSqueal :: MonadThrow m => SquealException -> m a+throwSqueal = throwM

@@ -167,6 +167,7 @@ import Control.Category import Control.Category.Free import Control.Monad+import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.Foldable (traverse_) import Data.Function ((&))@@ -177,7 +178,6 @@ import Data.Time (UTCTime) import Prelude hiding ((.), id) import System.Environment-import UnliftIO (MonadIO (..))  import qualified Data.Text.IO as Text (putStrLn) import qualified Generics.SOP as SOP@@ -201,7 +201,7 @@ import Squeal.PostgreSQL.Session.Monad import Squeal.PostgreSQL.Session.Result import Squeal.PostgreSQL.Session.Statement-import Squeal.PostgreSQL.Session.Transaction+import Squeal.PostgreSQL.Session.Transaction.Unsafe import Squeal.PostgreSQL.Query.From import Squeal.PostgreSQL.Query.Select import Squeal.PostgreSQL.Query.Table

@@ -31,11 +31,9 @@ import Control.Monad.Morph import Prelude hiding (id, (.)) -import qualified Generics.SOP as SOP-import qualified Generics.SOP.Record as SOP- import Squeal.PostgreSQL.Manipulation import Squeal.PostgreSQL.Session.Decode+import Squeal.PostgreSQL.Session.Encode import Squeal.PostgreSQL.Session.Result import Squeal.PostgreSQL.Session.Statement import Squeal.PostgreSQL.Query@@ -426,8 +424,7 @@ runQueryParams ::   ( MonadPQ db pq   , GenericParams db params x xs-  , SOP.IsRecord y ys-  , SOP.AllZip FromField row ys+  , GenericRow row y ys   ) => Query '[] '[] db params row     -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends     -> x -> pq (Result y)@@ -453,7 +450,7 @@ 4 -} runQuery-  :: (MonadPQ db pq, SOP.IsRecord y ys, SOP.AllZip FromField row ys)+  :: (MonadPQ db pq, GenericRow row y ys)   => Query '[] '[] db '[] row   -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends   -> pq (Result y)@@ -502,9 +499,8 @@ traversePrepared   :: ( MonadPQ db pq      , GenericParams db params x xs-     , Traversable list-     , SOP.IsRecord y ys-     , SOP.AllZip FromField row ys )+     , GenericRow row y ys+     , Traversable list )   => Manipulation '[] db params row   -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,   -- `Squeal.PostgreSQL.Manipulation.Update.update`,@@ -553,9 +549,8 @@ forPrepared   :: ( MonadPQ db pq      , GenericParams db params x xs-     , Traversable list-     , SOP.IsRecord y ys-     , SOP.AllZip FromField row ys )+     , GenericRow row y ys+     , Traversable list )   => list x   -> Manipulation '[] db params row   -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,

@@ -34,10 +34,10 @@   , OidOfField (..)   ) where +import Control.Monad.Catch import Control.Monad.Reader import Data.String import GHC.TypeLits-import UnliftIO (throwIO) import PostgreSQL.Binary.Decoding (valueParser, int)  import qualified Data.ByteString as ByteString@@ -173,24 +173,29 @@ oidOfTypedef (_ :: QualifiedAlias sch ty) = ReaderT $ \(SOP.K conn) -> do   resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary   case resultMaybe of-    Nothing -> throwIO $ ConnectionException "LibPQ.execParams"+    Nothing -> throwM $ ConnectionException oidErr     Just result -> do+      numRows <- LibPQ.ntuples result+      when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows       valueMaybe <- LibPQ.getvalue result 0 0       case valueMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.getvalue"+        Nothing -> throwM $ ConnectionException oidErr         Just value -> case valueParser int value of-          Left err -> throwIO $ DecodingException "oidOfTypedef" err+          Left err -> throwM $ DecodingException oidErr err           Right oid -> return $ LibPQ.Oid oid   where+    tyVal = symbolVal (SOP.Proxy @ty)+    schVal = symbolVal (SOP.Proxy @sch)+    oidErr = "oidOfTypedef " <> fromString (schVal <> "." <> tyVal)     q = ByteString.intercalate " "       [ "SELECT pg_type.oid"       , "FROM pg_type"       , "INNER JOIN pg_namespace"       , "ON pg_type.typnamespace = pg_namespace.oid"       , "WHERE pg_type.typname = "-      , "\'" <> fromString (symbolVal (SOP.Proxy @ty)) <> "\'"+      , "\'" <> fromString tyVal <> "\'"       , "AND pg_namespace.nspname = "-      , "\'" <> fromString (symbolVal (SOP.Proxy @sch)) <> "\'"+      , "\'" <> fromString schVal <> "\'"       , ";" ]  oidOfArrayTypedef@@ -200,22 +205,27 @@ oidOfArrayTypedef (_ :: QualifiedAlias sch ty) = ReaderT $ \(SOP.K conn) -> do   resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary   case resultMaybe of-    Nothing -> throwIO $ ConnectionException "LibPQ.execParams"+    Nothing -> throwM $ ConnectionException oidErr     Just result -> do+      numRows <- LibPQ.ntuples result+      when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows       valueMaybe <- LibPQ.getvalue result 0 0       case valueMaybe of-        Nothing -> throwIO $ ConnectionException "LibPQ.getvalue"+        Nothing -> throwM $ ConnectionException oidErr         Just value -> case valueParser int value of-          Left err -> throwIO $ DecodingException "oidOfArray" err+          Left err -> throwM $ DecodingException oidErr err           Right oid -> return $ LibPQ.Oid oid   where+    tyVal = symbolVal (SOP.Proxy @ty)+    schVal = symbolVal (SOP.Proxy @sch)+    oidErr = "oidOfArrayTypedef " <> fromString (schVal <> "." <> tyVal)     q = ByteString.intercalate " "       [ "SELECT pg_type.typelem"       , "FROM pg_type"       , "INNER JOIN pg_namespace"       , "ON pg_type.typnamespace = pg_namespace.oid"       , "WHERE pg_type.typname = "-      , "\'" <> fromString (symbolVal (SOP.Proxy @ty)) <> "\'"+      , "\'" <> fromString tyVal <> "\'"       , "AND pg_namespace.nspname = "-      , "\'" <> fromString (symbolVal (SOP.Proxy @sch)) <> "\'"+      , "\'" <> fromString schVal <> "\'"       , ";" ]

@@ -52,19 +52,20 @@   , destroyConnectionPool   ) where +import Control.Monad.Catch+import Control.Monad.IO.Class import Data.ByteString import Data.Time-import UnliftIO (MonadUnliftIO (..))-import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)+import Data.Pool  import Squeal.PostgreSQL.Type.Schema import Squeal.PostgreSQL.Session (PQ (..)) import Squeal.PostgreSQL.Session.Connection  -- | Create a striped pool of connections.--- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.+-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyConnectionPool` when you're done with the pool so that the connections are freed up as soon as possible. createConnectionPool-  :: forall (db :: SchemasType) io. MonadUnliftIO io+  :: forall (db :: SchemasType) io. MonadIO io   => ByteString   -- ^ The passed string can be empty to use all default parameters, or it can   -- contain one or more parameter settings separated by whitespace.@@ -82,7 +83,7 @@   -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.   -> io (Pool (K Connection db)) createConnectionPool conninfo stripes idle maxResrc =-  createPool (connectdb conninfo) finish stripes idle maxResrc+  liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc  {-| Temporarily take a connection from a `Pool`, perform an action with it,@@ -95,11 +96,16 @@ until a connection becomes available. -} usingConnectionPool-  :: MonadUnliftIO io+  :: (MonadIO io, MonadMask io)   => Pool (K Connection db) -- ^ pool   -> PQ db db io x -- ^ session   -> io x-usingConnectionPool pool (PQ session) = unK <$> withResource pool session+usingConnectionPool pool (PQ session) = mask $ \restore -> do+  (conn, local) <- liftIO $ takeResource pool+  ret <- restore (session conn) `onException`+            liftIO (destroyResource pool local conn)+  liftIO $ putResource local conn+  return $ unK ret  {- | Destroy all connections in all stripes in the pool.@@ -118,7 +124,7 @@ thus freeing up those connections sooner. -} destroyConnectionPool-  :: MonadUnliftIO io+  :: MonadIO io   => Pool (K Connection db) -- ^ pool   -> io ()-destroyConnectionPool = destroyAllResources+destroyConnectionPool = liftIO . destroyAllResources

@@ -10,38 +10,30 @@  {-# LANGUAGE     FlexibleContexts+  , FlexibleInstances   , GADTs   , LambdaCase   , OverloadedStrings   , ScopedTypeVariables   , TypeApplications+  , UndecidableInstances #-}  module Squeal.PostgreSQL.Session.Result   ( Result (..)-  , getRow-  , firstRow-  , getRows-  , nextRow-  , cmdStatus-  , cmdTuples-  , ntuples-  , nfields-  , resultStatus-  , okResult-  , resultErrorMessage-  , resultErrorCode+  , MonadResult (..)   , liftResult+  , nextRow   ) where  import Control.Exception (throw) import Control.Monad (when, (<=<))+import Control.Monad.Catch import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.Text (Text) import Data.Traversable (for) import Text.Read (readMaybe)-import UnliftIO (throwIO)  import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8@@ -68,20 +60,119 @@ instance Functor Result where   fmap f (Result decode result) = Result (fmap f decode) result --- | Get a row corresponding to a given row number from a `LibPQ.Result`,--- throwing an exception if the row number is out of bounds.-getRow :: MonadIO io => LibPQ.Row -> Result y -> io y-getRow r (Result decode result) = liftIO $ do-  numRows <- LibPQ.ntuples result-  numCols <- LibPQ.nfields result-  when (numRows < r) $ throw $ RowsException "getRow" r numRows-  row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]-  case SOP.fromList row' of-    Nothing -> throw $ ColumnsException "getRow" numCols-    Just row -> case execDecodeRow decode row of-      Left parseError -> throw $ DecodingException "getRow" parseError-      Right y -> return y+{- | A `MonadResult` operation extracts values+from the `Result` of a `Squeal.PostgreSQL.Session.Monad.MonadPQ` operation.+There is no need to define instances of `MonadResult`.+An instance of `MonadIO` implies an instance of `MonadResult`.+However, the constraint `MonadResult`+does not imply the constraint `MonadIO`.+-}+class Monad m => MonadResult m where+  -- | Get a row corresponding to a given row number from a `LibPQ.Result`,+  -- throwing an exception if the row number is out of bounds.+  getRow :: LibPQ.Row -> Result y -> m y+  -- | Get all rows from a `LibPQ.Result`.+  getRows :: Result y -> m [y]+  -- | Get the first row if possible from a `LibPQ.Result`.+  firstRow :: Result y -> m (Maybe y)+  -- | Returns the number of rows (tuples) in the query result.+  ntuples :: Result y -> m LibPQ.Row+  -- | Returns the number of columns (fields) in the query result.+  nfields :: Result y -> m LibPQ.Column+  {- |+  Returns the command status tag from the SQL command+  that generated the `Result`.+  Commonly this is just the name of the command,+  but it might include additional data such as the number of rows processed.+  -}+  cmdStatus :: Result y -> m Text+  {- |+  Returns the number of rows affected by the SQL command.+  This function returns `Just` the number of+  rows affected by the SQL statement that generated the `Result`.+  This function can only be used following the execution of a+  SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH,+  or COPY statement,or an EXECUTE of a prepared query that+  contains an INSERT, UPDATE, or DELETE statement.+  If the command that generated the PGresult was anything else,+  `cmdTuples` returns `Nothing`.+  -}+  cmdTuples :: Result y -> m (Maybe LibPQ.Row)+  -- | Returns the result status of the command.+  resultStatus :: Result y -> m LibPQ.ExecStatus+  -- | Check if a `Result`'s status is either `LibPQ.CommandOk`+  -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`.+  okResult :: Result y -> m ()+  -- | Returns the error message most recently generated by an operation+  -- on the connection.+  resultErrorMessage :: Result y -> m (Maybe ByteString)+  -- | Returns the error code most recently generated by an operation+  -- on the connection.+  --+  -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html+  resultErrorCode :: Result y -> m (Maybe ByteString) +instance (Monad io, MonadIO io) => MonadResult io where+  getRow r (Result decode result) = liftIO $ do+    numRows <- LibPQ.ntuples result+    numCols <- LibPQ.nfields result+    when (numRows < r) $ throw $ RowsException "getRow" r numRows+    row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]+    case SOP.fromList row' of+      Nothing -> throw $ ColumnsException "getRow" numCols+      Just row -> case execDecodeRow decode row of+        Left parseError -> throw $ DecodingException "getRow" parseError+        Right y -> return y++  getRows (Result decode result) = liftIO $ do+    numCols <- LibPQ.nfields result+    numRows <- LibPQ.ntuples result+    for [0 .. numRows - 1] $ \ r -> do+      row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]+      case SOP.fromList row' of+        Nothing -> throw $ ColumnsException "getRows" numCols+        Just row -> case execDecodeRow decode row of+          Left parseError -> throw $ DecodingException "getRows" parseError+          Right y -> return y++  firstRow (Result decode result) = liftIO $ do+    numRows <- LibPQ.ntuples result+    numCols <- LibPQ.nfields result+    if numRows <= 0 then return Nothing else do+      row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1]+      case SOP.fromList row' of+        Nothing -> throw $ ColumnsException "firstRow" numCols+        Just row -> case execDecodeRow decode row of+          Left parseError -> throw $ DecodingException "firstRow" parseError+          Right y -> return $ Just y++  ntuples = liftResult LibPQ.ntuples++  nfields = liftResult LibPQ.nfields++  resultStatus = liftResult LibPQ.resultStatus++  cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus)+    where+      getCmdStatus = \case+        Nothing -> throwM $ ConnectionException "LibPQ.cmdStatus"+        Just bytes -> return $ Text.decodeUtf8 bytes++  cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples)+    where+      getCmdTuples = \case+        Nothing -> throwM $ ConnectionException "LibPQ.cmdTuples"+        Just bytes -> return $+          if ByteString.null bytes+          then Nothing+          else fromInteger <$> readMaybe (Char8.unpack bytes)++  okResult = liftResult okResult_ ++  resultErrorMessage = liftResult LibPQ.resultErrorMessage++  resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)+ -- | Intended to be used for unfolding in streaming libraries, `nextRow` -- takes a total number of rows (which can be found with `ntuples`) -- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,@@ -102,85 +193,6 @@         Left parseError -> throw $ DecodingException "nextRow" parseError         Right y -> return $ Just (r+1, y) --- | Get all rows from a `LibPQ.Result`.-getRows :: MonadIO io => Result y -> io [y]-getRows (Result decode result) = liftIO $ do-  numCols <- LibPQ.nfields result-  numRows <- LibPQ.ntuples result-  for [0 .. numRows - 1] $ \ r -> do-    row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]-    case SOP.fromList row' of-      Nothing -> throw $ ColumnsException "getRows" numCols-      Just row -> case execDecodeRow decode row of-        Left parseError -> throw $ DecodingException "getRows" parseError-        Right y -> return y---- | Get the first row if possible from a `LibPQ.Result`.-firstRow :: MonadIO io => Result y -> io (Maybe y)-firstRow (Result decode result) = liftIO $ do-  numRows <- LibPQ.ntuples result-  numCols <- LibPQ.nfields result-  if numRows <= 0 then return Nothing else do-    row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1]-    case SOP.fromList row' of-      Nothing -> throw $ ColumnsException "firstRow" numCols-      Just row -> case execDecodeRow decode row of-        Left parseError -> throw $ DecodingException "firstRow" parseError-        Right y -> return $ Just y---- | Lifts actions on results from @LibPQ@.-liftResult-  :: MonadIO io-  => (LibPQ.Result -> IO x)-  -> Result y -> io x-liftResult f (Result _ result) = liftIO $ f result---- | Returns the number of rows (tuples) in the query result.-ntuples :: MonadIO io => Result y -> io LibPQ.Row-ntuples = liftResult LibPQ.ntuples---- | Returns the number of columns (fields) in the query result.-nfields :: MonadIO io => Result y -> io LibPQ.Column-nfields = liftResult LibPQ.nfields---- | Returns the result status of the command.-resultStatus :: MonadIO io => Result y -> io LibPQ.ExecStatus-resultStatus = liftResult LibPQ.resultStatus--{- |-Returns the command status tag from the SQL command-that generated the `Result`.-Commonly this is just the name of the command,-but it might include additional data such as the number of rows processed.--}-cmdStatus :: MonadIO io => Result y -> io Text-cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus)-  where-    getCmdStatus = \case-      Nothing -> throwIO $ ConnectionException "LibPQ.cmdStatus"-      Just bytes -> return $ Text.decodeUtf8 bytes--{- |-Returns the number of rows affected by the SQL command.-This function returns `Just` the number of-rows affected by the SQL statement that generated the `Result`.-This function can only be used following the execution of a-SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH,-or COPY statement,or an EXECUTE of a prepared query that-contains an INSERT, UPDATE, or DELETE statement.-If the command that generated the PGresult was anything else,-`cmdTuples` returns `Nothing`.--}-cmdTuples :: MonadIO io => Result y -> io (Maybe LibPQ.Row)-cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples)-  where-    getCmdTuples = \case-      Nothing -> throwIO $ ConnectionException "LibPQ.cmdTuples"-      Just bytes -> return $-        if ByteString.null bytes-        then Nothing-        else fromInteger <$> readMaybe (Char8.unpack bytes)- okResult_ :: MonadIO io => LibPQ.Result -> io () okResult_ result = liftIO $ do   status <- LibPQ.resultStatus result@@ -197,26 +209,12 @@             Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage"             Just msg -> throw . SQLException $ SQLState status stateCode msg --- | Check if a `Result`'s status is either `LibPQ.CommandOk`--- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`.-okResult :: MonadIO io => Result y -> io ()-okResult = liftResult okResult_ ---- | Returns the error message most recently generated by an operation--- on the connection.-resultErrorMessage-  :: MonadIO io => Result y -> io (Maybe ByteString)-resultErrorMessage = liftResult LibPQ.resultErrorMessage---- | Returns the error code most recently generated by an operation--- on the connection.------ https://www.postgresql.org/docs/current/static/errcodes-appendix.html-resultErrorCode+-- | Lifts actions on results from @LibPQ@.+liftResult   :: MonadIO io-  => Result y-  -> io (Maybe ByteString)-resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)+  => (LibPQ.Result -> IO x)+  -> Result y -> io x+liftResult f (Result _ result) = liftIO $ f result  execDecodeRow   :: DecodeRow row y

@@ -11,8 +11,7 @@ -}  {-# LANGUAGE-    ConstraintKinds-  , DataKinds+    DataKinds   , DeriveFunctor   , DeriveFoldable   , DeriveGeneric@@ -26,15 +25,12 @@   ( Statement (..)   , query   , manipulation-  , GenericParams-  , GenericRow   ) where  import Data.Functor.Contravariant import Data.Profunctor (Profunctor (..))  import qualified Generics.SOP as SOP-import qualified Generics.SOP.Record as SOP  import Squeal.PostgreSQL.Manipulation import Squeal.PostgreSQL.Session.Decode@@ -86,24 +82,6 @@ instance RenderSQL (Statement db x y) where   renderSQL (Manipulation _ _ q) = renderSQL q   renderSQL (Query _ _ q) = renderSQL q---- | A `GenericParams` constraint to ensure that--- a Haskell type is a product type,--- all its terms have known Oids,--- and can be encoded to corresponding--- Postgres types.-type GenericParams db params x xs =-  ( SOP.All (OidOfNull db) params-  , SOP.IsProductType x xs-  , SOP.AllZip (ToParam db) params xs )---- | A `GenericRow` constraint to ensure that--- a Haskell type is a record type,--- and all its fields and can be decoded from corresponding--- Postgres fields.-type GenericRow row y ys =-  ( SOP.IsRecord y ys-  , SOP.AllZip FromField row ys )  -- | Smart constructor for a structured query language statement query ::

@@ -9,245 +9,148 @@ -}  {-# LANGUAGE-    DataKinds-  , FlexibleContexts-  , LambdaCase-  , OverloadedStrings-  , TypeInType+    MonoLocalBinds+  , RankNTypes #-}  module Squeal.PostgreSQL.Session.Transaction   ( -- * Transaction-    transactionally+    Transaction+  , transactionally   , transactionally_   , transactionallyRetry+  , transactionallyRetry_   , ephemerally   , ephemerally_-  , begin-  , commit-  , rollback+  , withSavepoint     -- * Transaction Mode   , TransactionMode (..)   , defaultMode   , longRunningMode+  , retryMode   , IsolationLevel (..)   , AccessMode (..)   , DeferrableMode (..)   ) where -import UnliftIO+import Control.Monad.Catch+import Data.ByteString -import Squeal.PostgreSQL.Manipulation-import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Session.Exception import Squeal.PostgreSQL.Session.Monad+import Squeal.PostgreSQL.Session.Result+import Squeal.PostgreSQL.Session.Transaction.Unsafe+  ( TransactionMode (..)+  , defaultMode+  , longRunningMode+  , retryMode+  , IsolationLevel (..)+  , AccessMode (..)+  , DeferrableMode (..)+  )+import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe +{- | A type of "safe" `Transaction`s,+do-blocks that permit only+database operations, pure functions, and synchronous exception handling+forbidding arbitrary `IO` operations.++To permit arbitrary `IO`,++>>> import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe++Then use the @Unsafe@ qualified form of the functions below.++A safe `Transaction` can be run in two ways,++1) it can be run directly in `IO` because as a+   universally quantified type,+   @Transaction db x@ permits interpretation in "subtypes" like+   @(MonadPQ db m, MonadIO m, MonadCatch m) => m x@+   or+   @PQ db db IO x@++2) it can be run in a transaction block, using+   `transactionally`, `ephemerally`,+   or `transactionallyRetry`+-} +type Transaction db x = forall m.+  ( MonadPQ db m+  , MonadResult m+  , MonadCatch m+  ) => m x+ {- | Run a computation `transactionally`;-first `begin`,+first `Unsafe.begin`, then run the computation,-`onException` `rollback` and rethrow the exception,-otherwise `commit` and `return` the result.+`onException` `Unsafe.rollback` and rethrow the exception,+otherwise `Unsafe.commit` and `return` the result. -} transactionally-  :: (MonadUnliftIO tx, MonadPQ db tx)+  :: (MonadMask tx, MonadResult tx, MonadPQ db tx)   => TransactionMode-  -> tx x -- ^ run inside a transaction+  -> Transaction db x -- ^ run inside a transaction   -> tx x-transactionally mode tx = mask $ \restore -> do-  manipulate_ $ begin mode-  result <- restore tx `onException` (manipulate_ rollback)-  manipulate_ commit-  return result+transactionally = Unsafe.transactionally  -- | Run a computation `transactionally_`, in `defaultMode`. transactionally_-  :: (MonadUnliftIO tx, MonadPQ db tx)-  => tx x -- ^ run inside a transaction+  :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+  => Transaction db x -- ^ run inside a transaction   -> tx x-transactionally_ = transactionally defaultMode+transactionally_ = Unsafe.transactionally_  {- | `transactionallyRetry` a computation; -* first `begin`,+* first `Unsafe.begin`, * then `try` the computation,-  - if it raises a serialization failure then `rollback` and restart the transaction,-  - if it raises any other exception then `rollback` and rethrow the exception,-  - otherwise `commit` and `return` the result.+  - if it raises a serialization failure or deadloack detection,+    then `Unsafe.rollback` and restart the transaction,+  - if it raises any other exception then `Unsafe.rollback` and rethrow the exception,+  - otherwise `Unsafe.commit` and `return` the result. -} transactionallyRetry-  :: (MonadUnliftIO tx, MonadPQ db tx)+  :: (MonadMask tx, MonadResult tx, MonadPQ db tx)   => TransactionMode-  -> tx x -- ^ run inside a transaction+  -> Transaction db x -- ^ run inside a transaction   -> tx x-transactionallyRetry mode tx = mask $ \restore ->-  loop . try $ do-    x <- restore tx-    manipulate_ commit-    return x-  where-    loop attempt = do-      manipulate_ $ begin mode-      attempt >>= \case-        Left (SerializationFailure _) -> do-          manipulate_ rollback-          loop attempt-        Left err -> do-          manipulate_ rollback-          throwIO err-        Right x -> return x+transactionallyRetry = Unsafe.transactionallyRetry +{- | `transactionallyRetry` in `retryMode`. -}+transactionallyRetry_+  :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+  => Transaction db x -- ^ run inside a transaction+  -> tx x+transactionallyRetry_ = Unsafe.transactionallyRetry_+ {- | Run a computation `ephemerally`;-Like `transactionally` but always `rollback`, useful in testing.+Like `transactionally` but always `Unsafe.rollback`, useful in testing. -} ephemerally-  :: (MonadUnliftIO tx, MonadPQ db tx)+  :: (MonadMask tx, MonadResult tx, MonadPQ db tx)   => TransactionMode-  -> tx x -- ^ run inside an ephemeral transaction+  -> Transaction db x -- ^ run inside an ephemeral transaction   -> tx x-ephemerally mode tx = mask $ \restore -> do-  manipulate_ $ begin mode-  result <- restore tx `onException` (manipulate_ rollback)-  manipulate_ rollback-  return result+ephemerally = Unsafe.ephemerally  {- | Run a computation `ephemerally` in `defaultMode`. -} ephemerally_-  :: (MonadUnliftIO tx, MonadPQ db tx)-  => tx x -- ^ run inside an ephemeral transaction+  :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+  => Transaction db x -- ^ run inside an ephemeral transaction   -> tx x-ephemerally_ = ephemerally defaultMode---- | @BEGIN@ a transaction.-begin :: TransactionMode -> Manipulation_ db () ()-begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode---- | @COMMIT@ a transaction.-commit :: Manipulation_ db () ()-commit = UnsafeManipulation "COMMIT"---- | @ROLLBACK@ a transaction.-rollback :: Manipulation_ db () ()-rollback = UnsafeManipulation "ROLLBACK"---- | The available transaction characteristics are the transaction `IsolationLevel`,--- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.-data TransactionMode = TransactionMode-  { isolationLevel :: IsolationLevel-  , accessMode  :: AccessMode-  , deferrableMode :: DeferrableMode-  } deriving (Show, Eq)---- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`,--- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.-defaultMode :: TransactionMode-defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable---- | `TransactionMode` with a `Serializable` `IsolationLevel`,--- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.--- This mode is well suited for long-running reports or backups.-longRunningMode :: TransactionMode-longRunningMode = TransactionMode Serializable ReadOnly Deferrable---- | Render a `TransactionMode`.-instance RenderSQL TransactionMode where-  renderSQL mode =-    "ISOLATION LEVEL"-      <+> renderSQL (isolationLevel mode)-      <+> renderSQL (accessMode mode)-      <+> renderSQL (deferrableMode mode)---- | The SQL standard defines four levels of transaction isolation.--- The most strict is `Serializable`, which is defined by the standard in a paragraph--- which says that any concurrent execution of a set of `Serializable` transactions is--- guaranteed to produce the same effect as running them one at a time in some order.--- The other three levels are defined in terms of phenomena, resulting from interaction--- between concurrent transactions, which must not occur at each level.--- The phenomena which are prohibited at various levels are:------ __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.------ __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data--- has been modified by another transaction (that committed since the initial read).------ __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy--- a search condition and finds that the set of rows satisfying the condition--- has changed due to another recently-committed transaction.------ __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent--- with all possible orderings of running those transactions one at a time.------ In PostgreSQL, you can request any of the four standard transaction--- isolation levels, but internally only three distinct isolation levels are implemented,--- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.--- This is because it is the only sensible way to map the standard isolation levels to--- PostgreSQL's multiversion concurrency control architecture.-data IsolationLevel-  = Serializable-  -- ^ Dirty read is not possible.-  -- Nonrepeatable read is not possible.-  -- Phantom read is not possible.-  -- Serialization anomaly is not possible.-  | RepeatableRead-  -- ^ Dirty read is not possible.-  -- Nonrepeatable read is not possible.-  -- Phantom read is not possible.-  -- Serialization anomaly is possible.-  | ReadCommitted-  -- ^ Dirty read is not possible.-  -- Nonrepeatable read is possible.-  -- Phantom read is possible.-  -- Serialization anomaly is possible.-  | ReadUncommitted-  -- ^ Dirty read is not possible.-  -- Nonrepeatable read is possible.-  -- Phantom read is possible.-  -- Serialization anomaly is possible.-  deriving (Show, Eq)---- | Render an `IsolationLevel`.-instance RenderSQL IsolationLevel where-  renderSQL = \case-    Serializable -> "SERIALIZABLE"-    ReadCommitted -> "READ COMMITTED"-    ReadUncommitted -> "READ UNCOMMITTED"-    RepeatableRead -> "REPEATABLE READ"---- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.--- `ReadWrite` is the default. When a transaction is `ReadOnly`,--- the following SQL commands are disallowed:--- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@--- if the table they would write to is not a temporary table;--- all @CREATE@, @ALTER@, and @DROP@ commands;--- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;--- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.--- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.-data AccessMode-  = ReadWrite-  | ReadOnly-  deriving (Show, Eq)---- | Render an `AccessMode`.-instance RenderSQL AccessMode where-  renderSQL = \case-    ReadWrite -> "READ WRITE"-    ReadOnly -> "READ ONLY"+ephemerally_ = Unsafe.ephemerally_ --- | The `Deferrable` transaction property has no effect--- unless the transaction is also `Serializable` and `ReadOnly`.--- When all three of these properties are selected for a transaction,--- the transaction may block when first acquiring its snapshot,--- after which it is able to run without the normal overhead of a--- `Serializable` transaction and without any risk of contributing--- to or being canceled by a serialization failure.--- This `longRunningMode` is well suited for long-running reports or backups.-data DeferrableMode-  = Deferrable-  | NotDeferrable-  deriving (Show, Eq)+{- | `withSavepoint`, used in a transaction block,+allows a form of nested transactions,+creating a savepoint, then running a transaction,+rolling back to the savepoint if it returned `Left`,+then releasing the savepoint and returning transaction's result. --- | Render a `DeferrableMode`.-instance RenderSQL DeferrableMode where-  renderSQL = \case-    Deferrable -> "DEFERRABLE"-    NotDeferrable -> "NOT DEFERRABLE"+Make sure to run `withSavepoint` in a transaction block,+not directly or you will provoke a SQL exception.+-}+withSavepoint+  :: ByteString -- ^ savepoint name+  -> Transaction db (Either e x)+  -> Transaction db (Either e x)+withSavepoint = Unsafe.withSavepoint

@@ -0,0 +1,299 @@+{-|+Module: Squeal.PostgreSQL.Session.Transaction.Unsafe+Description: unsafe transaction control language+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++transaction control language permitting arbitrary `IO`+-}++{-# LANGUAGE+    DataKinds+  , FlexibleContexts+  , LambdaCase+  , OverloadedStrings+  , TypeInType+#-}++module Squeal.PostgreSQL.Session.Transaction.Unsafe+  ( -- * Transaction+    transactionally+  , transactionally_+  , transactionallyRetry+  , transactionallyRetry_+  , ephemerally+  , ephemerally_+  , begin+  , commit+  , rollback+  , withSavepoint+    -- * Transaction Mode+  , TransactionMode (..)+  , defaultMode+  , retryMode+  , longRunningMode+  , IsolationLevel (..)+  , AccessMode (..)+  , DeferrableMode (..)+  ) where++import Control.Monad+import Control.Monad.Catch+import Data.ByteString+import Data.Either++import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Session.Exception+import Squeal.PostgreSQL.Session.Monad++{- | Run a computation `transactionally`;+first `begin`,+then run the computation,+`onException` `rollback` and rethrow the exception,+otherwise `commit` and `return` the result.+-}+transactionally+  :: (MonadMask tx, MonadPQ db tx)+  => TransactionMode+  -> tx x -- ^ run inside a transaction+  -> tx x+transactionally mode tx = mask $ \restore -> do+  manipulate_ $ begin mode+  result <- restore tx `onException` manipulate_ rollback+  manipulate_ commit+  return result++-- | Run a computation `transactionally_`, in `defaultMode`.+transactionally_+  :: (MonadMask tx, MonadPQ db tx)+  => tx x -- ^ run inside a transaction+  -> tx x+transactionally_ = transactionally defaultMode++{- |+`transactionallyRetry` a computation;++* first `begin`,+* then `try` the computation,+  - if it raises a serialization failure or deadlock detection,+    then `rollback` and restart the transaction,+  - if it raises any other exception then `rollback` and rethrow the exception,+  - otherwise `commit` and `return` the result.+-}+transactionallyRetry+  :: (MonadMask tx, MonadPQ db tx)+  => TransactionMode+  -> tx x -- ^ run inside a transaction+  -> tx x+transactionallyRetry mode tx = mask $ \restore ->+  loop . try $ do+    x <- restore tx+    manipulate_ commit+    return x+  where+    loop attempt = do+      manipulate_ $ begin mode+      attempt >>= \case+        Left (SerializationFailure _) -> do+          manipulate_ rollback+          loop attempt+        Left (DeadlockDetected _) -> do+          manipulate_ rollback+          loop attempt+        Left err -> do+          manipulate_ rollback+          throwM err+        Right x -> return x++{- | `transactionallyRetry` in `retryMode`. -}+transactionallyRetry_+  :: (MonadMask tx, MonadPQ db tx)+  => tx x -- ^ run inside a transaction+  -> tx x+transactionallyRetry_ = transactionallyRetry retryMode++{- | Run a computation `ephemerally`;+Like `transactionally` but always `rollback`, useful in testing.+-}+ephemerally+  :: (MonadMask tx, MonadPQ db tx)+  => TransactionMode+  -> tx x -- ^ run inside an ephemeral transaction+  -> tx x+ephemerally mode tx = mask $ \restore -> do+  manipulate_ $ begin mode+  result <- restore tx `onException` (manipulate_ rollback)+  manipulate_ rollback+  return result++{- | Run a computation `ephemerally` in `defaultMode`. -}+ephemerally_+  :: (MonadMask tx, MonadPQ db tx)+  => tx x -- ^ run inside an ephemeral transaction+  -> tx x+ephemerally_ = ephemerally defaultMode++-- | @BEGIN@ a transaction.+begin :: TransactionMode -> Manipulation_ db () ()+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode++-- | @COMMIT@ a transaction.+commit :: Manipulation_ db () ()+commit = UnsafeManipulation "COMMIT"++-- | @ROLLBACK@ a transaction.+rollback :: Manipulation_ db () ()+rollback = UnsafeManipulation "ROLLBACK"++{- | `withSavepoint`, used in a transaction block,+allows a form of nested transactions,+creating a savepoint, then running a transaction,+rolling back to the savepoint if it returned `Left`,+then releasing the savepoint and returning transaction's result.++Make sure to run `withSavepoint` in a transaction block,+not directly or you will provoke a SQL exception.+-}+withSavepoint+  :: MonadPQ db tx+  => ByteString -- ^ savepoint name+  -> tx (Either e x)+  -> tx (Either e x)+withSavepoint savepoint tx = do+  let svpt = "SAVEPOINT" <+> savepoint+  manipulate_ $ UnsafeManipulation $ svpt+  e_x <- tx+  when (isLeft e_x) $+    manipulate_ $ UnsafeManipulation $ "ROLLBACK TO" <+> svpt+  manipulate_ $ UnsafeManipulation $ "RELEASE" <+> svpt+  return e_x++-- | The available transaction characteristics are the transaction `IsolationLevel`,+-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.+data TransactionMode = TransactionMode+  { isolationLevel :: IsolationLevel+  , accessMode  :: AccessMode+  , deferrableMode :: DeferrableMode+  } deriving (Show, Eq)++-- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`,+-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.+defaultMode :: TransactionMode+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable++-- | `TransactionMode` with a `Serializable` `IsolationLevel`,+-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`,+-- appropriate for short-lived queries or manipulations.+retryMode :: TransactionMode+retryMode = TransactionMode Serializable ReadWrite NotDeferrable++-- | `TransactionMode` with a `Serializable` `IsolationLevel`,+-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.+-- This mode is well suited for long-running reports or backups.+longRunningMode :: TransactionMode+longRunningMode = TransactionMode Serializable ReadOnly Deferrable++-- | Render a `TransactionMode`.+instance RenderSQL TransactionMode where+  renderSQL mode =+    "ISOLATION LEVEL"+      <+> renderSQL (isolationLevel mode)+      <+> renderSQL (accessMode mode)+      <+> renderSQL (deferrableMode mode)++-- | The SQL standard defines four levels of transaction isolation.+-- The most strict is `Serializable`, which is defined by the standard in a paragraph+-- which says that any concurrent execution of a set of `Serializable` transactions is+-- guaranteed to produce the same effect as running them one at a time in some order.+-- The other three levels are defined in terms of phenomena, resulting from interaction+-- between concurrent transactions, which must not occur at each level.+-- The phenomena which are prohibited at various levels are:+--+-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.+--+-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data+-- has been modified by another transaction (that committed since the initial read).+--+-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy+-- a search condition and finds that the set of rows satisfying the condition+-- has changed due to another recently-committed transaction.+--+-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent+-- with all possible orderings of running those transactions one at a time.+--+-- In PostgreSQL, you can request any of the four standard transaction+-- isolation levels, but internally only three distinct isolation levels are implemented,+-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.+-- This is because it is the only sensible way to map the standard isolation levels to+-- PostgreSQL's multiversion concurrency control architecture.+data IsolationLevel+  = Serializable+  -- ^ Dirty read is not possible.+  -- Nonrepeatable read is not possible.+  -- Phantom read is not possible.+  -- Serialization anomaly is not possible.+  | RepeatableRead+  -- ^ Dirty read is not possible.+  -- Nonrepeatable read is not possible.+  -- Phantom read is not possible.+  -- Serialization anomaly is possible.+  | ReadCommitted+  -- ^ Dirty read is not possible.+  -- Nonrepeatable read is possible.+  -- Phantom read is possible.+  -- Serialization anomaly is possible.+  | ReadUncommitted+  -- ^ Dirty read is not possible.+  -- Nonrepeatable read is possible.+  -- Phantom read is possible.+  -- Serialization anomaly is possible.+  deriving (Show, Eq)++-- | Render an `IsolationLevel`.+instance RenderSQL IsolationLevel where+  renderSQL = \case+    Serializable -> "SERIALIZABLE"+    ReadCommitted -> "READ COMMITTED"+    ReadUncommitted -> "READ UNCOMMITTED"+    RepeatableRead -> "REPEATABLE READ"++-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.+-- `ReadWrite` is the default. When a transaction is `ReadOnly`,+-- the following SQL commands are disallowed:+-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@+-- if the table they would write to is not a temporary table;+-- all @CREATE@, @ALTER@, and @DROP@ commands;+-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;+-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.+-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.+data AccessMode+  = ReadWrite+  | ReadOnly+  deriving (Show, Eq)++-- | Render an `AccessMode`.+instance RenderSQL AccessMode where+  renderSQL = \case+    ReadWrite -> "READ WRITE"+    ReadOnly -> "READ ONLY"++-- | The `Deferrable` transaction property has no effect+-- unless the transaction is also `Serializable` and `ReadOnly`.+-- When all three of these properties are selected for a transaction,+-- the transaction may block when first acquiring its snapshot,+-- after which it is able to run without the normal overhead of a+-- `Serializable` transaction and without any risk of contributing+-- to or being canceled by a serialization failure.+-- This `longRunningMode` is well suited for long-running reports or backups.+data DeferrableMode+  = Deferrable+  | NotDeferrable+  deriving (Show, Eq)++-- | Render a `DeferrableMode`.+instance RenderSQL DeferrableMode where+  renderSQL = \case+    Deferrable -> "DEFERRABLE"+    NotDeferrable -> "NOT DEFERRABLE"

@@ -5,7 +5,7 @@ Maintainer: eitan@morphism.tech Stability: experimental -types+storage newtypes -} {-# LANGUAGE     AllowAmbiguousTypes@@ -33,7 +33,8 @@ #-}  module Squeal.PostgreSQL.Type-  ( Money (..)+  ( -- * Storage newtypes+    Money (..)   , Json (..)   , Jsonb (..)   , Composite (..)

@@ -41,6 +41,8 @@   , Elem   , In   , Length+  , SubList+  , SubsetList   ) where  import Control.Category.Free@@ -107,3 +109,48 @@ type family Length (xs :: [k]) :: Nat where   Length '[] = 0   Length (_ : xs) = 1 + Length xs++{- | `SubList` checks that one type level list is a sublist of another,+with the same ordering.++>>> :kind! SubList '[1,2,3] '[4,5,6]+SubList '[1,2,3] '[4,5,6] :: Bool+= 'False+>>> :kind! SubList '[1,2,3] '[1,2,3,4]+SubList '[1,2,3] '[1,2,3,4] :: Bool+= 'True+>>> :kind! SubList '[1,2,3] '[0,1,0,2,0,3]+SubList '[1,2,3] '[0,1,0,2,0,3] :: Bool+= 'True+>>> :kind! SubList '[1,2,3] '[3,2,1]+SubList '[1,2,3] '[3,2,1] :: Bool+= 'False+-}+type family SubList (xs :: [k]) (ys :: [k]) :: Bool where+  SubList '[] ys = 'True+  SubList (x ': xs) '[] = 'False+  SubList (x ': xs) (x ': ys) = SubList xs ys+  SubList (x ': xs) (y ': ys) = SubList (x ': xs) ys++{- | `SubsetList` checks that one type level list is a subset of another,+regardless of ordering and repeats.++>>> :kind! SubsetList '[1,2,3] '[4,5,6]+SubsetList '[1,2,3] '[4,5,6] :: Bool+= 'False+>>> :kind! SubsetList '[1,2,3] '[1,2,3,4]+SubsetList '[1,2,3] '[1,2,3,4] :: Bool+= 'True+>>> :kind! SubsetList '[1,2,3] '[0,1,0,2,0,3]+SubsetList '[1,2,3] '[0,1,0,2,0,3] :: Bool+= 'True+>>> :kind! SubsetList '[1,2,3] '[3,2,1]+SubsetList '[1,2,3] '[3,2,1] :: Bool+= 'True+>>> :kind! SubsetList '[1,1,1] '[3,2,1]+SubsetList '[1,1,1] '[3,2,1] :: Bool+= 'True+-}+type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where+  SubsetList '[] ys = 'True+  SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys

@@ -52,6 +52,8 @@   ) where  import Data.Aeson (Value)+import Data.Functor.Const (Const)+import Data.Functor.Constant (Constant) import Data.Kind (Type) import Data.Int (Int16, Int32, Int64) import Data.Scientific (Scientific)@@ -170,6 +172,12 @@ instance IsPG (VarChar n) where type PG (VarChar n) = 'PGvarchar n -- | `PGvarchar` instance IsPG (FixChar n) where type PG (FixChar n) = 'PGchar n+-- | `PG hask`+instance IsPG hask => IsPG (Const hask tag) where type PG (Const hask tag) = PG hask+-- | `PG hask`+instance IsPG hask => IsPG (SOP.K hask tag) where type PG (SOP.K hask tag) = PG hask+-- | `PG hask`+instance IsPG hask => IsPG (Constant hask tag) where type PG (Constant hask tag) = PG hask  -- | `PGmoney` instance IsPG Money where type PG Money = 'PGmoney

@@ -50,6 +50,10 @@   , SchemaType   , SchemasType   , Public+    -- * Database Subsets+  , SubDB+  , SubsetDB+  , ElemDB     -- * Constraint   , (:=>)   , Optionality (..)@@ -439,6 +443,41 @@   SetSchema sch0 sch1 schema0 schema1 obj srt ty db = Alter sch1     (Create obj (srt ty) schema1)     (Alter sch0 (DropSchemum obj srt schema0) db)++{- | `SubDB` checks that one `SchemasType` is a sublist of another,+with the same ordering.++>>> :kind! SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]]+SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]] :: Bool+= 'True+-}+type family SubDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where+  SubDB '[] db1 = 'True+  SubDB (sch ': db0) '[] = 'False+  SubDB (sch ::: schema0 ': db0) (sch ::: schema1 ': db1) =+    If (SubList schema0 schema1)+      (SubDB db0 db1)+      (SubDB (sch ::: schema0 ': db0) db1)+  SubDB db0 (sch1 ': db1) = SubDB db0 db1++{- | `SubsetDB` checks that one `SchemasType` is a subset of another,+regardless of ordering.++>>> :kind! SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]]+SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]] :: Bool+= 'True+-}+type family SubsetDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where+  SubsetDB '[] db1 = 'True+  SubsetDB (sch ': db0) db1 = ElemDB sch db1 && SubsetDB db0 db1++{- | `ElemDB` checks that a schema may be found as a subset of another in a database,+regardless of ordering.+-}+type family ElemDB (sch :: (Symbol, SchemaType)) (db :: SchemasType) :: Bool where+  ElemDB sch '[] = 'False+  ElemDB (sch ::: schema0) (sch ::: schema1 ': _) = SubsetList schema0 schema1+  ElemDB sch (_ ': schs) = ElemDB sch schs  -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where

@@ -124,7 +124,7 @@   :: forall x    . ( ToPG DB x, FromPG x, Inline x      , OidOf DB (PG x), PGTyped DB (PG x)-     , Show x, Eq x )+     , Show x, Eq x, NullPG x ~ 'NotNull (PG x) )   => TypeExpression DB ('NotNull (PG x))   -> Gen x   -> (PropertyName, Property)@@ -134,7 +134,7 @@   :: forall x    . ( ToPG DB x, FromPG x, Inline x      , OidOf DB (PG x), PGTyped DB (PG x)-     , Show x, Eq x )+     , Show x, Eq x, NullPG x ~ 'NotNull (PG x) )   => (x -> x)   -> TypeExpression DB ('NotNull (PG x))   -> Gen x

@@ -10,6 +10,7 @@   , MultiParamTypeClasses   , OverloadedLabels   , OverloadedStrings+  , RankNTypes   , StandaloneDeriving   , TypeApplications   , TypeFamilies@@ -107,7 +108,9 @@      let       testUser = User "TestUser"+      newUser :: User -> Transaction DB ()       newUser = manipulateParams_ insertUser+      insertUserTwice :: Transaction DB ()       insertUserTwice = newUser testUser >> newUser testUser       err23505 = UniqueViolation $ Char8.unlines         [ "ERROR:  duplicate key value violates unique constraint \"unique_names\""@@ -129,12 +132,10 @@       let         qry :: Query_ (Public '[]) () (Only Char)         qry = values_ (inline 'a' `as` #fromOnly)-        session = usingConnectionPool pool . transactionally_ $ do-          result <- runQuery qry-          Just (Only chr) <- firstRow result-          return chr+        session = usingConnectionPool pool $ transactionally_ $+          firstRow =<< runQuery qry       chrs <- replicateConcurrently 10 session-      chrs `shouldSatisfy` all (== 'a')+      chrs `shouldSatisfy` all (== Just (Only 'a'))    describe "Ranges" $