diff --git a/bench/Gauge/DBHelpers.hs b/bench/Gauge/DBHelpers.hs --- a/bench/Gauge/DBHelpers.hs +++ b/bench/Gauge/DBHelpers.hs @@ -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 diff --git a/squeal-postgresql.cabal b/squeal-postgresql.cabal --- a/squeal-postgresql.cabal +++ b/squeal-postgresql.cabal @@ -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 diff --git a/src/Squeal/PostgreSQL.hs b/src/Squeal/PostgreSQL.hs --- a/src/Squeal/PostgreSQL.hs +++ b/src/Squeal/PostgreSQL.hs @@ -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 +in the toplevel of Squeal's Git repo. -} module Squeal.PostgreSQL ( module X diff --git a/src/Squeal/PostgreSQL/Definition/Index.hs b/src/Squeal/PostgreSQL/Definition/Index.hs --- a/src/Squeal/PostgreSQL/Definition/Index.hs +++ b/src/Squeal/PostgreSQL/Definition/Index.hs @@ -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 <> ";" diff --git a/src/Squeal/PostgreSQL/Expression.hs b/src/Squeal/PostgreSQL/Expression.hs --- a/src/Squeal/PostgreSQL/Expression.hs +++ b/src/Squeal/PostgreSQL/Expression.hs @@ -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) diff --git a/src/Squeal/PostgreSQL/Expression/Aggregate.hs b/src/Squeal/PostgreSQL/Expression/Aggregate.hs --- a/src/Squeal/PostgreSQL/Expression/Aggregate.hs +++ b/src/Squeal/PostgreSQL/Expression/Aggregate.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Expression/Comparison.hs b/src/Squeal/PostgreSQL/Expression/Comparison.hs --- a/src/Squeal/PostgreSQL/Expression/Comparison.hs +++ b/src/Squeal/PostgreSQL/Expression/Comparison.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Expression/Composite.hs b/src/Squeal/PostgreSQL/Expression/Composite.hs --- a/src/Squeal/PostgreSQL/Expression/Composite.hs +++ b/src/Squeal/PostgreSQL/Expression/Composite.hs @@ -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 <> ".*") diff --git a/src/Squeal/PostgreSQL/Expression/Inline.hs b/src/Squeal/PostgreSQL/Expression/Inline.hs --- a/src/Squeal/PostgreSQL/Expression/Inline.hs +++ b/src/Squeal/PostgreSQL/Expression/Inline.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Expression/Json.hs b/src/Squeal/PostgreSQL/Expression/Json.hs --- a/src/Squeal/PostgreSQL/Expression/Json.hs +++ b/src/Squeal/PostgreSQL/Expression/Json.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Expression/Null.hs b/src/Squeal/PostgreSQL/Expression/Null.hs --- a/src/Squeal/PostgreSQL/Expression/Null.hs +++ b/src/Squeal/PostgreSQL/Expression/Null.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Expression/Subquery.hs b/src/Squeal/PostgreSQL/Expression/Subquery.hs --- a/src/Squeal/PostgreSQL/Expression/Subquery.hs +++ b/src/Squeal/PostgreSQL/Expression/Subquery.hs @@ -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)) diff --git a/src/Squeal/PostgreSQL/Expression/Text.hs b/src/Squeal/PostgreSQL/Expression/Text.hs --- a/src/Squeal/PostgreSQL/Expression/Text.hs +++ b/src/Squeal/PostgreSQL/Expression/Text.hs @@ -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" diff --git a/src/Squeal/PostgreSQL/Expression/Time.hs b/src/Squeal/PostgreSQL/Expression/Time.hs --- a/src/Squeal/PostgreSQL/Expression/Time.hs +++ b/src/Squeal/PostgreSQL/Expression/Time.hs @@ -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" diff --git a/src/Squeal/PostgreSQL/Expression/Window.hs b/src/Squeal/PostgreSQL/Expression/Window.hs --- a/src/Squeal/PostgreSQL/Expression/Window.hs +++ b/src/Squeal/PostgreSQL/Expression/Window.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Query.hs b/src/Squeal/PostgreSQL/Query.hs --- a/src/Squeal/PostgreSQL/Query.hs +++ b/src/Squeal/PostgreSQL/Query.hs @@ -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 $ diff --git a/src/Squeal/PostgreSQL/Query/Table.hs b/src/Squeal/PostgreSQL/Query/Table.hs --- a/src/Squeal/PostgreSQL/Query/Table.hs +++ b/src/Squeal/PostgreSQL/Query/Table.hs @@ -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} {----------------------------------------- diff --git a/src/Squeal/PostgreSQL/Query/With.hs b/src/Squeal/PostgreSQL/Query/With.hs --- a/src/Squeal/PostgreSQL/Query/With.hs +++ b/src/Squeal/PostgreSQL/Query/With.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session.hs b/src/Squeal/PostgreSQL/Session.hs --- a/src/Squeal/PostgreSQL/Session.hs +++ b/src/Squeal/PostgreSQL/Session.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Decode.hs b/src/Squeal/PostgreSQL/Session/Decode.hs --- a/src/Squeal/PostgreSQL/Session/Decode.hs +++ b/src/Squeal/PostgreSQL/Session/Decode.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Encode.hs b/src/Squeal/PostgreSQL/Session/Encode.hs --- a/src/Squeal/PostgreSQL/Session/Encode.hs +++ b/src/Squeal/PostgreSQL/Session/Encode.hs @@ -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) diff --git a/src/Squeal/PostgreSQL/Session/Exception.hs b/src/Squeal/PostgreSQL/Session/Exception.hs --- a/src/Squeal/PostgreSQL/Session/Exception.hs +++ b/src/Squeal/PostgreSQL/Session/Exception.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Migration.hs b/src/Squeal/PostgreSQL/Session/Migration.hs --- a/src/Squeal/PostgreSQL/Session/Migration.hs +++ b/src/Squeal/PostgreSQL/Session/Migration.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Monad.hs b/src/Squeal/PostgreSQL/Session/Monad.hs --- a/src/Squeal/PostgreSQL/Session/Monad.hs +++ b/src/Squeal/PostgreSQL/Session/Monad.hs @@ -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`, diff --git a/src/Squeal/PostgreSQL/Session/Oid.hs b/src/Squeal/PostgreSQL/Session/Oid.hs --- a/src/Squeal/PostgreSQL/Session/Oid.hs +++ b/src/Squeal/PostgreSQL/Session/Oid.hs @@ -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 <> "\'" , ";" ] diff --git a/src/Squeal/PostgreSQL/Session/Pool.hs b/src/Squeal/PostgreSQL/Session/Pool.hs --- a/src/Squeal/PostgreSQL/Session/Pool.hs +++ b/src/Squeal/PostgreSQL/Session/Pool.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Result.hs b/src/Squeal/PostgreSQL/Session/Result.hs --- a/src/Squeal/PostgreSQL/Session/Result.hs +++ b/src/Squeal/PostgreSQL/Session/Result.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Statement.hs b/src/Squeal/PostgreSQL/Session/Statement.hs --- a/src/Squeal/PostgreSQL/Session/Statement.hs +++ b/src/Squeal/PostgreSQL/Session/Statement.hs @@ -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 :: diff --git a/src/Squeal/PostgreSQL/Session/Transaction.hs b/src/Squeal/PostgreSQL/Session/Transaction.hs --- a/src/Squeal/PostgreSQL/Session/Transaction.hs +++ b/src/Squeal/PostgreSQL/Session/Transaction.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs b/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs @@ -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" diff --git a/src/Squeal/PostgreSQL/Type.hs b/src/Squeal/PostgreSQL/Type.hs --- a/src/Squeal/PostgreSQL/Type.hs +++ b/src/Squeal/PostgreSQL/Type.hs @@ -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 (..) diff --git a/src/Squeal/PostgreSQL/Type/List.hs b/src/Squeal/PostgreSQL/Type/List.hs --- a/src/Squeal/PostgreSQL/Type/List.hs +++ b/src/Squeal/PostgreSQL/Type/List.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Type/PG.hs b/src/Squeal/PostgreSQL/Type/PG.hs --- a/src/Squeal/PostgreSQL/Type/PG.hs +++ b/src/Squeal/PostgreSQL/Type/PG.hs @@ -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 diff --git a/src/Squeal/PostgreSQL/Type/Schema.hs b/src/Squeal/PostgreSQL/Type/Schema.hs --- a/src/Squeal/PostgreSQL/Type/Schema.hs +++ b/src/Squeal/PostgreSQL/Type/Schema.hs @@ -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 diff --git a/test/Property.hs b/test/Property.hs --- a/test/Property.hs +++ b/test/Property.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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" $