diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ ![squeal-icon](https://raw.githubusercontent.com/morphismtech/squeal/dev/squeal.gif) -[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal) +[![GithubWorkflowCI](https://github.com/morphismtech/squeal/actions/workflows/ci.yml/badge.svg)](https://github.com/morphismtech/squeal/actions/workflows/ci.yml) [Github](https://github.com/morphismtech/squeal) 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/exe/Example.hs b/exe/Example.hs --- a/exe/Example.hs +++ b/exe/Example.hs @@ -9,8 +9,15 @@ , TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main, main2, upsertUser) where +import Control.Monad.Except (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32) import Data.Text (Text) @@ -46,6 +53,7 @@ '[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext + , "type" ::: 'NoDef :=> 'NotNull 'PGtext ]) , "members" ::: 'Table ( '[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"] @@ -54,7 +62,7 @@ , "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ]) ] -type Schemas +type Schemas = '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ] setup :: Definition (Public '[]) Schemas @@ -83,7 +91,8 @@ >>> createTable (#org ! #organizations) ( serial `as` #id :* - (text & notNullable) `as` #name ) + (text & notNullable) `as` #name :* + (text & notNullable) `as` #type ) ( primaryKey #id `as` #pk_organizations ) >>> createTable (#org ! #members) @@ -93,7 +102,7 @@ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_member :* foreignKey #organization (#org ! #organizations) #id (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_organization ) - + teardown :: Definition Schemas (Public '[]) teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org @@ -106,6 +115,11 @@ insertEmail = insertInto_ (#user ! #emails) (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) +insertOrganization :: Manipulation_ Schemas (Text, OrganizationType) (Only Int32) +insertOrganization = insertInto (#org ! #organizations) + (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #type)) + (OnConflict (OnConstraint #pk_organizations) DoNothing) (Returning_ (#id `as` #fromOnly)) + getUsers :: Query_ Schemas () User getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec) @@ -113,6 +127,36 @@ & innerJoin (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id)) ) +getOrganizations :: Query_ Schemas () Organization +getOrganizations = select_ + ( #o ! #id `as` #orgId :* + #o ! #name `as` #orgName :* + #o ! #type `as` #orgType + ) + (from (table (#org ! #organizations `as` #o))) + +getOrganizationsBy :: + forall hsty. + (ToPG Schemas hsty) => + Condition + 'Ungrouped + '[] + '[] + Schemas + '[NullPG hsty] + '["o" ::: ["id" ::: NotNull PGint4, "name" ::: NotNull PGtext, "type" ::: NotNull PGtext]] -> + Query_ Schemas (Only hsty) Organization +getOrganizationsBy condition = + select_ + ( #o ! #id `as` #orgId :* + #o ! #name `as` #orgName :* + #o ! #type `as` #orgType + ) + ( + from (table (#org ! #organizations `as` #o)) + & where_ condition + ) + upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) () upsertUser = insertInto (#user ! #users `as` #u) (Values_ (Set (param @1) `as` #id :* setUser)) @@ -137,28 +181,98 @@ , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3,Nothing, Just 4]) ] +data Organization + = Organization + { orgId :: Int32 + , orgName :: Text + , orgType :: OrganizationType + } deriving (Show, GHC.Generic) +instance SOP.Generic Organization +instance SOP.HasDatatypeInfo Organization + +data OrganizationType + = ForProfit + | NonProfit + deriving (Show, GHC.Generic) +instance SOP.Generic OrganizationType +instance SOP.HasDatatypeInfo OrganizationType + +instance IsPG OrganizationType where + type PG OrganizationType = 'PGtext +instance ToPG db OrganizationType where + toPG = toPG . toText + where + toText ForProfit = "for-profit" :: Text + toText NonProfit = "non-profit" :: Text + +instance FromPG OrganizationType where + fromPG = do + value <- fromPG @Text + fromText value + where + fromText "for-profit" = pure ForProfit + fromText "non-profit" = pure NonProfit + fromText value = throwError $ "Invalid organization type: \"" <> value <> "\"" + +organizations :: [Organization] +organizations = + [ Organization { orgId = 1, orgName = "ACME", orgType = ForProfit } + , Organization { orgId = 2, orgName = "Haskell Foundation", orgType = NonProfit } + ] + session :: (MonadIO pq, MonadPQ Schemas pq) => pq () session = do - liftIO $ Char8.putStrLn "manipulating" - idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users]) - ids <- traverse (fmap fromOnly . getRow 0) (idResults :: [Result (Only Int32)]) - traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) - liftIO $ Char8.putStrLn "querying" + liftIO $ Char8.putStrLn "===> manipulating" + userIdResults <- traversePrepared insertUser [(userName user, userVec user) | user <- users] + userIds <- traverse (fmap fromOnly . getRow 0) (userIdResults :: [Result (Only Int32)]) + traversePrepared_ insertEmail (zip (userIds :: [Int32]) (userEmail <$> users)) + + orgIdResults <- traversePrepared + insertOrganization + [(orgName organization, orgType organization) | organization <- organizations] + _ <- traverse (fmap fromOnly . getRow 0) (orgIdResults :: [Result (Only Int32)]) + + liftIO $ Char8.putStrLn "===> querying: users" usersResult <- runQuery getUsers usersRows <- getRows usersResult liftIO $ print (usersRows :: [User]) + liftIO $ Char8.putStrLn "===> querying: organizations: all" + organizationsResult1 <- runQuery getOrganizations + organizationRows1 <- getRows organizationsResult1 + liftIO $ print (organizationRows1 :: [Organization]) + + liftIO $ Char8.putStrLn "===> querying: organizations: by ID (2)" + organizationsResult2 <- runQueryParams + (getOrganizationsBy @Int32 ((#o ! #id) .== param @1)) (Only (2 :: Int32)) + organizationRows2 <- getRows organizationsResult2 + liftIO $ print (organizationRows2 :: [Organization]) + + liftIO $ Char8.putStrLn "===> querying: organizations: by name (ACME)" + organizationsResult3 <- runQueryParams + (getOrganizationsBy @Text ((#o ! #name) .== param @1)) (Only ("ACME" :: Text)) + organizationRows3 <- getRows organizationsResult3 + liftIO $ print (organizationRows3 :: [Organization]) + + liftIO $ Char8.putStrLn "===> querying: organizations: by type (non-profit)" + organizationsResult4 <- runQueryParams + (getOrganizationsBy @Text ((#o ! #type) .== param @1)) (Only NonProfit) + organizationRows4 <- getRows organizationsResult4 + liftIO $ print (organizationRows4 :: [Organization]) + main :: IO () main = do - Char8.putStrLn "squeal" + Char8.putStrLn "===> squeal" connectionString <- pure "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Char8.putStrLn $ "connecting to " <> connectionString connection0 <- connectdb connectionString - Char8.putStrLn "setting up schema" + + Char8.putStrLn "===> setting up schema" connection1 <- execPQ (define setup) connection0 connection2 <- execPQ session connection1 - Char8.putStrLn "tearing down schema" + + Char8.putStrLn "===> tearing down schema" connection3 <- execPQ (define teardown) connection2 finish connection3 diff --git a/squeal-postgresql.cabal b/squeal-postgresql.cabal --- a/squeal-postgresql.cabal +++ b/squeal-postgresql.cabal @@ -1,17 +1,17 @@ +cabal-version: 2.2 name: squeal-postgresql -version: 0.7.0.1 +version: 0.9.2.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal bug-reports: https://github.com/morphismtech/squeal/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Eitan Chatav maintainer: eitan.chatav@gmail.com -copyright: Copyright (c) 2017 Morphism, LLC +copyright: Copyright (c) 2022 Morphism, LLC category: Database build-type: Simple -cabal-version: >=1.18 extra-doc-files: README.md source-repository head @@ -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 @@ -97,6 +98,8 @@ , exceptions >= 0.10.3 , free-categories >= 0.2.0.0 , generics-sop >= 0.5.1.0 + , hashable >= 1.3.0.0 + , iproute >= 1.7.0 , mmorph >= 1.1.3 , monad-control >= 1.0.2.3 , mtl >= 2.2.2 @@ -112,7 +115,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 @@ -125,13 +127,14 @@ build-depends: base >= 4.12.0.0 && < 5.0 , doctest >= 0.16.3 - , squeal-postgresql + if impl(ghc >= 9.0.0) + buildable: False test-suite properties 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.hs b/src/Squeal/PostgreSQL/Definition.hs --- a/src/Squeal/PostgreSQL/Definition.hs +++ b/src/Squeal/PostgreSQL/Definition.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses , UndecidableInstances diff --git a/src/Squeal/PostgreSQL/Definition/Comment.hs b/src/Squeal/PostgreSQL/Definition/Comment.hs --- a/src/Squeal/PostgreSQL/Definition/Comment.hs +++ b/src/Squeal/PostgreSQL/Definition/Comment.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} diff --git a/src/Squeal/PostgreSQL/Definition/Constraint.hs b/src/Squeal/PostgreSQL/Definition/Constraint.hs --- a/src/Squeal/PostgreSQL/Definition/Constraint.hs +++ b/src/Squeal/PostgreSQL/Definition/Constraint.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} diff --git a/src/Squeal/PostgreSQL/Definition/Function.hs b/src/Squeal/PostgreSQL/Definition/Function.hs --- a/src/Squeal/PostgreSQL/Definition/Function.hs +++ b/src/Squeal/PostgreSQL/Definition/Function.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} 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 @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} @@ -173,14 +174,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/Definition/Procedure.hs b/src/Squeal/PostgreSQL/Definition/Procedure.hs --- a/src/Squeal/PostgreSQL/Definition/Procedure.hs +++ b/src/Squeal/PostgreSQL/Definition/Procedure.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} diff --git a/src/Squeal/PostgreSQL/Definition/Schema.hs b/src/Squeal/PostgreSQL/Definition/Schema.hs --- a/src/Squeal/PostgreSQL/Definition/Schema.hs +++ b/src/Squeal/PostgreSQL/Definition/Schema.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} diff --git a/src/Squeal/PostgreSQL/Definition/Table.hs b/src/Squeal/PostgreSQL/Definition/Table.hs --- a/src/Squeal/PostgreSQL/Definition/Table.hs +++ b/src/Squeal/PostgreSQL/Definition/Table.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} diff --git a/src/Squeal/PostgreSQL/Definition/Type.hs b/src/Squeal/PostgreSQL/Definition/Type.hs --- a/src/Squeal/PostgreSQL/Definition/Type.hs +++ b/src/Squeal/PostgreSQL/Definition/Type.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} diff --git a/src/Squeal/PostgreSQL/Definition/View.hs b/src/Squeal/PostgreSQL/Definition/View.hs --- a/src/Squeal/PostgreSQL/Definition/View.hs +++ b/src/Squeal/PostgreSQL/Definition/View.hs @@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableSuperClasses #-} 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 @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances , RankNTypes @@ -342,7 +343,7 @@ :: (Has sch db schema, Has fun schema ('Function ('[x] :=> 'Returns y))) => QualifiedAlias sch fun -- ^ function name -> Fun db x y -function = unsafeFunction . renderSQL +function f = unsafeFunction $ renderSQL f -- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: inline 'a') -- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, (E'a' :: char(1))) @@ -369,7 +370,7 @@ , SListI xs ) => QualifiedAlias sch fun -- ^ function alias -> FunN db xs y -functionN = unsafeFunctionN . renderSQL +functionN f = unsafeFunctionN $ renderSQL f instance Num (Expression grp lat with db params from (null 'PGint2)) where @@ -585,6 +586,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 @@ -429,6 +431,13 @@ -- ^ `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 AggregateAll args sorts filters -> @@ -556,6 +565,48 @@ variance = unsafeAggregate "variance" varPop = unsafeAggregate "var_pop" varSamp = unsafeAggregate "var_samp" + +-- provides a nicer type error when we forget to group by +-- note that we need to make our 'a' polymorphic so that we can still match when it's ambiguous +instance ( TypeError ('Text "Cannot use aggregate functions to construct an Ungrouped Expression. Add a 'groupBy' to your TableExpression. If you want to aggregate across the entire result set, use 'groupBy Nil'.") + , a ~ AggregateArg + ) => Aggregate a (Expression 'Ungrouped) where + countStar = impossibleAggregateError + count = impossibleAggregateError + sum_ = impossibleAggregateError + arrayAgg = impossibleAggregateError + jsonAgg = impossibleAggregateError + jsonbAgg = impossibleAggregateError + bitAnd = impossibleAggregateError + bitOr = impossibleAggregateError + boolAnd = impossibleAggregateError + boolOr = impossibleAggregateError + every = impossibleAggregateError + max_ = impossibleAggregateError + min_ = impossibleAggregateError + avg = impossibleAggregateError + corr = impossibleAggregateError + covarPop = impossibleAggregateError + covarSamp = impossibleAggregateError + regrAvgX = impossibleAggregateError + regrAvgY = impossibleAggregateError + regrCount = impossibleAggregateError + regrIntercept = impossibleAggregateError + regrR2 = impossibleAggregateError + regrSlope = impossibleAggregateError + regrSxx = impossibleAggregateError + regrSxy = impossibleAggregateError + regrSyy = impossibleAggregateError + stddev = impossibleAggregateError + stddevPop = impossibleAggregateError + stddevSamp = impossibleAggregateError + variance = impossibleAggregateError + varPop = impossibleAggregateError + varSamp = impossibleAggregateError + +-- | helper function for our errors above +impossibleAggregateError :: a +impossibleAggregateError = error "impossible; called aggregate function for Ungrouped even though the Aggregate instance has a type error constraint." -- | escape hatch to define aggregate functions unsafeAggregate diff --git a/src/Squeal/PostgreSQL/Expression/Array.hs b/src/Squeal/PostgreSQL/Expression/Array.hs --- a/src/Squeal/PostgreSQL/Expression/Array.hs +++ b/src/Squeal/PostgreSQL/Expression/Array.hs @@ -37,6 +37,15 @@ , unnest , arrAny , arrAll + , arrayAppend + , arrayPrepend + , arrayCat + , arrayPosition + , arrayPositionBegins + , arrayPositions + , arrayRemoveNull + , arrayReplace + , trimArray ) where import Data.String @@ -47,6 +56,7 @@ import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Expression.Null import Squeal.PostgreSQL.Expression.Type import Squeal.PostgreSQL.Query.From.Set import Squeal.PostgreSQL.Render @@ -207,7 +217,7 @@ arrAll :: Expression grp lat with db params from ty1 -- ^ expression -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Expression grp lat with db params from ('Null ('PGvararray ty2)) -- ^ array + -> Expression grp lat with db params from (null ('PGvararray ty2)) -- ^ array -> Condition grp lat with db params from arrAll x (?) xs = x ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL xs)) @@ -237,6 +247,45 @@ arrAny :: Expression grp lat with db params from ty1 -- ^ expression -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Expression grp lat with db params from ('Null ('PGvararray ty2)) -- ^ array + -> Expression grp lat with db params from (null ('PGvararray ty2)) -- ^ array -> Condition grp lat with db params from arrAny x (?) xs = x ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL xs)) + +arrayAppend :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty) +arrayAppend = unsafeFunctionN "array_append" + +arrayPrepend :: '[ty, null ('PGvararray ty)] ---> null ('PGvararray ty) +arrayPrepend = unsafeFunctionN "array_prepend" + +arrayCat + :: '[null ('PGvararray ty), null ('PGvararray ty)] + ---> null ('PGvararray ty) +arrayCat = unsafeFunctionN "array_cat" + +arrayPosition :: '[null ('PGvararray ty), ty] ---> 'Null 'PGint8 +arrayPosition = unsafeFunctionN "array_position" + +arrayPositionBegins + :: '[null ('PGvararray ty), ty, null 'PGint8] ---> 'Null 'PGint8 +arrayPositionBegins = unsafeFunctionN "array_position" + +arrayPositions + :: '[null ('PGvararray ty), ty] + ---> null ('PGvararray ('NotNull 'PGint8)) +arrayPositions = unsafeFunctionN "array_positions" + +arrayRemove :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty) +arrayRemove = unsafeFunctionN "array_remove" + +arrayRemoveNull :: null ('PGvararray ('Null ty)) --> null ('PGvararray ('NotNull ty)) +arrayRemoveNull arr = UnsafeExpression (renderSQL (arrayRemove (arr *: null_))) + +arrayReplace + :: '[null ('PGvararray ty), ty, ty] + ---> null ('PGvararray ty) +arrayReplace = unsafeFunctionN "array_replace" + +trimArray + :: '[null ('PGvararray ty), 'NotNull 'PGint8] + ---> null ('PGvararray ty) +trimArray = unsafeFunctionN "trim_array" 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 @@ -11,7 +11,8 @@ {-# LANGUAGE OverloadedStrings , RankNTypes - , TypeInType + , DataKinds + , PolyKinds , TypeOperators #-} @@ -150,7 +151,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 +159,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 <> ".*") @@ -81,13 +81,15 @@ -- >>> printSQL $ i & field #complex #imaginary -- (ROW((0.0 :: float8), (1.0 :: float8))::"complex")."imaginary" field - :: ( Has sch db schema - , Has tydef schema ('Typedef ('PGcomposite row)) - , Has field row ty) - => QualifiedAlias sch tydef -- ^ row type + :: ( relss ~ DbRelations db + , Has sch relss rels + , Has rel rels row + , Has field row ty + ) + => QualifiedAlias sch rel -- ^ row type -> Alias field -- ^ field name -> Expression grp lat with db params from ('NotNull ('PGcomposite row)) -> Expression grp lat with db params from ty -field td fld expr = UnsafeExpression $ - parenthesized (renderSQL expr <> "::" <> renderSQL td) +field rel fld expr = UnsafeExpression $ + parenthesized (renderSQL expr <> "::" <> renderSQL rel) <> "." <> renderSQL fld 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,8 @@ import Data.ByteString.Lazy (toStrict) import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec) import Data.ByteString.Builder.Scientific (scientificBuilder) +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) @@ -98,29 +100,41 @@ True -> true False -> false instance JSON.ToJSON x => Inline (Json x) where - inline = inferredtype . UnsafeExpression - . singleQuotedUtf8 . toStrict . JSON.encode . getJson + inline (Json x) + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . toStrict + . JSON.encode + $ x instance JSON.ToJSON x => Inline (Jsonb x) where - inline = inferredtype . UnsafeExpression - . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb + inline (Jsonb x) + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . toStrict + . JSON.encode + $ x instance Inline Char where inline chr = inferredtype . UnsafeExpression $ "E\'" <> fromString (escape chr) <> "\'" -instance Inline String where inline = fromString +instance Inline String where inline x = fromString x instance Inline Int16 where - inline + inline x = inferredtype . UnsafeExpression . toStrict . toLazyByteString . int16Dec + $ x instance Inline Int32 where - inline + inline x = inferredtype . UnsafeExpression . toStrict . toLazyByteString . int32Dec + $ x instance Inline Int64 where inline x = if x == minBound @@ -148,26 +162,33 @@ where decimal = toStrict . toLazyByteString . doubleDec instance Inline Scientific where - inline + inline x = inferredtype . UnsafeExpression . toStrict . toLazyByteString . scientificBuilder -instance Inline Text where inline = fromString . Text.unpack -instance Inline Lazy.Text where inline = fromString . Lazy.Text.unpack + $ x +instance Inline Text where inline x = fromString . Text.unpack $ x +instance Inline Lazy.Text where inline x = fromString . Lazy.Text.unpack $ x instance (KnownNat n, 1 <= n) => Inline (VarChar n) where - inline + inline x = inferredtype . UnsafeExpression . escapeQuotedText . getVarChar + $ x instance (KnownNat n, 1 <= n) => Inline (FixChar n) where - inline + inline x = inferredtype . UnsafeExpression . escapeQuotedText . getFixChar + $ x +instance Inline x => Inline (Const x tag) where inline (Const x) = inline x +instance Inline x => Inline (SOP.K x tag) where inline (SOP.K x) = inline x +instance Inline x => Inline (Constant x tag) where + inline (Constant x) = inline x instance Inline DiffTime where inline dt = let @@ -179,58 +200,64 @@ interval_ (fromIntegral secs) Seconds +! interval_ (fromIntegral microsecs) Microseconds instance Inline Day where - inline + inline x = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString . iso8601Show + $ x instance Inline UTCTime where - inline + inline x = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString . iso8601Show + $ x instance Inline (TimeOfDay, TimeZone) where - inline + inline x = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString . formatShow (timeOfDayAndOffsetFormat ExtendedFormat) + $ x instance Inline TimeOfDay where - inline + inline x = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString - . iso8601Show + . iso8601Show + $ x instance Inline LocalTime where - inline + inline x = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString . iso8601Show + $ x instance Inline (Range Int32) where - inline = range int4range . fmap inline + inline x = range int4range . fmap (\y -> inline y) $ x instance Inline (Range Int64) where - inline = range int8range . fmap inline + inline x = range int8range . fmap (\y -> inline y) $ x instance Inline (Range Scientific) where - inline = range numrange . fmap inline + inline x = range numrange . fmap (\y -> inline y) $ x instance Inline (Range LocalTime) where - inline = range tsrange . fmap inline + inline x = range tsrange . fmap (\y -> inline y) $ x instance Inline (Range UTCTime) where - inline = range tstzrange . fmap inline + inline x = range tstzrange . fmap (\y -> inline y) $ x instance Inline (Range Day) where - inline = range daterange . fmap inline + inline x = range daterange . fmap (\y -> inline y) $ x instance Inline UUID where - inline + inline x = inferredtype . UnsafeExpression . singleQuotedUtf8 . toASCIIBytes + $ x instance Inline Money where inline moolah = inferredtype . UnsafeExpression $ fromString (show dollars) @@ -239,17 +266,17 @@ (dollars,pennies) = cents moolah `divMod` 100 instance InlineParam x (NullPG x) => Inline (VarArray [x]) where - inline (VarArray xs) = array (inlineParam <$> xs) + inline (VarArray xs) = array ((\x -> inlineParam x) <$> xs) instance InlineParam x (NullPG x) => Inline (VarArray (Vector x)) where - inline (VarArray xs) = array (inlineParam <$> toList xs) + inline (VarArray xs) = array ((\x -> inlineParam x) <$> toList xs) instance Inline Oid where inline (Oid o) = inferredtype . UnsafeExpression . fromString $ show o instance ( SOP.IsEnumType x , SOP.HasDatatypeInfo x ) => Inline (Enumerated x) where - inline = + inline (Enumerated x) = let gshowConstructor :: NP SOP.ConstructorInfo xss @@ -267,22 +294,22 @@ . gshowConstructor (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x))) . SOP.from - . getEnumerated + $ x instance ( SOP.IsRecord x xs , SOP.AllZip InlineField xs (RowPG x) ) => Inline (Composite x) where - inline + inline (Composite x) = row . SOP.htrans (SOP.Proxy @InlineField) inlineField . SOP.toRecord - . getComposite + $ x -- | Lifts `Inline` to `NullType`s. class InlineParam x ty where inlineParam :: x -> Expr ty instance (Inline x, pg ~ PG x) => InlineParam x ('NotNull pg) where inlineParam = inline instance (Inline x, pg ~ PG x) => InlineParam (Maybe x) ('Null pg) where - inlineParam = maybe null_ inline + inlineParam x = maybe null_ (\y -> inline y) x -- | Lifts `Inline` to fields. class InlineField 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 @@ -334,8 +336,8 @@ {- | Expands the outermost JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonEach (inline (Json (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json)) +>>> printSQL (select Star (from (jsonEach (inline (Json (object ["a" .= "foo"])))))) +SELECT * FROM json_each(('{"a":"foo"}' :: json)) -} jsonEach :: null 'PGjson -|-> ("json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]) @@ -343,8 +345,8 @@ {- | Expands the outermost binary JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonbEach (inline (Jsonb (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb)) +>>> printSQL (select Star (from (jsonbEach (inline (Jsonb (object ["a" .= "foo"])))))) +SELECT * FROM jsonb_each(('{"a":"foo"}' :: jsonb)) -} jsonbEach :: null 'PGjsonb -|-> @@ -353,18 +355,28 @@ {- | Expands the outermost JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonEachText (inline (Json (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json)) +>>> printSQL (select Star (from (jsonEachText (inline (Json (object ["a" .= "foo"])))))) +SELECT * FROM json_each_text(('{"a":"foo"}' :: json)) -} jsonEachText :: null 'PGjson -|-> ("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"])))))) -SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb)) +>>> printSQL (select Star (from (jsonbEachText (inline (Jsonb (object ["a" .= "foo"])))))) +SELECT * FROM jsonb_each_text(('{"a":"foo"}' :: jsonb)) -} jsonbEachText :: null 'PGjsonb -|-> @@ -373,8 +385,8 @@ {- | Returns set of keys in the outermost JSON object. ->>> printSQL (jsonObjectKeys (inline (Json (object ["a" .= "foo", "b" .= "bar"])))) -json_object_keys(('{"a":"foo","b":"bar"}' :: json)) +>>> printSQL (jsonObjectKeys (inline (Json (object ["a" .= "foo"])))) +json_object_keys(('{"a":"foo"}' :: json)) -} jsonObjectKeys :: null 'PGjson -|-> @@ -383,13 +395,23 @@ {- | Returns set of keys in the outermost JSON object. ->>> printSQL (jsonbObjectKeys (inline (Jsonb (object ["a" .= "foo", "b" .= "bar"])))) -jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb)) +>>> printSQL (jsonbObjectKeys (inline (Jsonb (object ["a" .= "foo"])))) +jsonb_object_keys(('{"a":"foo"}' :: jsonb)) -} jsonbObjectKeys :: 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,15 +10,17 @@ {-# LANGUAGE DataKinds + , KindSignatures , OverloadedStrings , RankNTypes + , TypeFamilies , TypeOperators #-} module Squeal.PostgreSQL.Expression.Null ( -- * Null null_ - , notNull + , just_ , unsafeNotNull , monoNotNull , coalesce @@ -27,6 +29,9 @@ , isNotNull , matchNull , nullIf + , CombineNullity + -- deprecated + , notNull ) where import Squeal.PostgreSQL.Expression @@ -46,8 +51,13 @@ -- | analagous to `Just` -- --- >>> printSQL $ notNull true +-- >>> printSQL $ just_ true -- TRUE +just_ :: 'NotNull ty --> 'Null ty +just_ = UnsafeExpression . renderSQL + +-- | analagous to `Just` +{-# DEPRECATED notNull "use just_ instead" #-} notNull :: 'NotNull ty --> 'Null ty notNull = UnsafeExpression . renderSQL @@ -65,7 +75,7 @@ :: (forall null. Expression grp lat with db params from (null ty)) -- ^ null polymorphic -> Expression grp lat with db params from ('NotNull ty) -monoNotNull = id +monoNotNull x = x -- | return the leftmost value which is not NULL -- @@ -121,3 +131,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/Parameter.hs b/src/Squeal/PostgreSQL/Expression/Parameter.hs --- a/src/Squeal/PostgreSQL/Expression/Parameter.hs +++ b/src/Squeal/PostgreSQL/Expression/Parameter.hs @@ -21,6 +21,7 @@ , RankNTypes , ScopedTypeVariables , TypeApplications + , TypeFamilies , TypeOperators , UndecidableInstances #-} @@ -29,8 +30,14 @@ ( -- * Parameter HasParameter (parameter) , param + -- * Parameter Internals + , HasParameter' + , ParamOutOfBoundsError + , ParamTypeMismatchError ) where +import Data.Kind (Constraint) +import GHC.Exts (Any) import GHC.TypeLits import Squeal.PostgreSQL.Expression @@ -49,11 +56,11 @@ separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -} -class KnownNat n => HasParameter - (n :: Nat) +class KnownNat ix => HasParameter + (ix :: Nat) (params :: [NullType]) (ty :: NullType) - | n params -> ty where + | ix params -> ty where -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. -- -- >>> printSQL (parameter @1 int4) @@ -62,12 +69,57 @@ :: TypeExpression db ty -> Expression grp lat with db params from ty parameter ty = UnsafeExpression $ parenthesized $ - "$" <> renderNat @n <+> "::" + "$" <> renderNat @ix <+> "::" <+> renderSQL ty -instance {-# OVERLAPPING #-} params ~ (x ': xs) => HasParameter 1 params x -instance {-# OVERLAPPABLE #-} - (KnownNat n, HasParameter (n-1) xs x, params ~ (y ': xs)) - => HasParameter n params x + +-- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating, +-- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@ +instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x +instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x + +-- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to +-- include the full parameter list in our errors. +class KnownNat ix => HasParameter' + (originalIx :: Nat) + (allParams :: [NullType]) + (ix :: Nat) + (params :: [NullType]) + (ty :: NullType) + | ix params -> ty where +instance {-# OVERLAPS #-} + ( params ~ (y ': xs) + , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError' + , ParamOutOfBoundsError originalIx allParams params + , ParamTypeMismatchError originalIx allParams x y + ) => HasParameter' originalIx allParams 1 params x +instance {-# OVERLAPS #-} + ( KnownNat ix + , HasParameter' originalIx allParams (ix-1) xs x + , params ~ (y ': xs) + , ParamOutOfBoundsError originalIx allParams params + ) + => HasParameter' originalIx allParams ix params x + +-- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but +-- find a different field than we expected, or when we find ourself out of bounds +type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where + ParamOutOfBoundsError originalIx allParams '[] = TypeError + ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams) + ParamOutOfBoundsError _ _ _ = () + +-- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but +-- find a different field than we expected, or when we find ourself out of bounds +type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where + ParamTypeMismatchError _ _ found found = () + ParamTypeMismatchError originalIx allParams found expected = TypeError + ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx + ':$$: 'Text "in 1-indexed parameter list:" + ':$$: 'Text " " ':<>: 'ShowType allParams + ':$$: 'Text "" + ':$$: 'Text "Expected: " ':<>: 'ShowType expected + ':$$: 'Text "But found: " ':<>: 'ShowType found + ':$$: 'Text "" + ) -- | `param` takes a `Nat` using type application and for basic types, -- infers a `TypeExpression`. diff --git a/src/Squeal/PostgreSQL/Expression/Range.hs b/src/Squeal/PostgreSQL/Expression/Range.hs --- a/src/Squeal/PostgreSQL/Expression/Range.hs +++ b/src/Squeal/PostgreSQL/Expression/Range.hs @@ -147,11 +147,11 @@ whole = NonEmpty Infinite Infinite -- | range is contained by -(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool) +(.<@) :: Operator (null0 ty) (null1 ('PGrange ty)) ('Null 'PGbool) (.<@) = unsafeBinaryOp "<@" -- | contains range -(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool) +(@>.) :: Operator (null0 ('PGrange ty)) (null1 ty) ('Null 'PGbool) (@>.) = unsafeBinaryOp "@>" -- | strictly left of, 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/Type.hs b/src/Squeal/PostgreSQL/Expression/Type.hs --- a/src/Squeal/PostgreSQL/Expression/Type.hs +++ b/src/Squeal/PostgreSQL/Expression/Type.hs @@ -34,6 +34,8 @@ , inferredtype -- * Type Expression , TypeExpression (..) + , typerow + , typeenum , typedef , typetable , typeview @@ -172,6 +174,31 @@ instance RenderSQL (TypeExpression db ty) where renderSQL = renderTypeExpression +-- | The composite type corresponding to a relation can be expressed +-- by its alias. A relation is either a composite type, a table or a view. +-- It subsumes `typetable` and `typeview` and partly overlaps `typedef`. +typerow + :: ( relss ~ DbRelations db + , Has sch relss rels + , Has rel rels row + ) + => QualifiedAlias sch rel + -- ^ type alias + -> TypeExpression db (null ('PGcomposite row)) +typerow = UnsafeTypeExpression . renderSQL + +-- | An enumerated type can be expressed by its alias. +-- `typeenum` is subsumed by `typedef`. +typeenum + :: ( enumss ~ DbEnums db + , Has sch enumss enums + , Has enum enums labels + ) + => QualifiedAlias sch enum + -- ^ type alias + -> TypeExpression db (null ('PGenum labels)) +typeenum = UnsafeTypeExpression . renderSQL + -- | The enum or composite type in a `Typedef` can be expressed by its alias. typedef :: (Has sch db schema, Has td schema ('Typedef ty)) @@ -181,7 +208,7 @@ typedef = UnsafeTypeExpression . renderSQL -- | The composite type corresponding to a `Table` definition can be expressed --- by its alias. +-- by its alias. It is subsumed by `typerow` typetable :: (Has sch db schema, Has tab schema ('Table table)) => QualifiedAlias sch tab @@ -190,7 +217,7 @@ typetable = UnsafeTypeExpression . renderSQL -- | The composite type corresponding to a `View` definition can be expressed --- by its alias. +-- by its alias. It is subsumed by `typerow`. typeview :: (Has sch db schema, Has vw schema ('View view)) => QualifiedAlias sch vw @@ -377,13 +404,15 @@ instance PGTyped db ('PGrange 'PGtimestamptz) where pgtype = tstzrange instance PGTyped db ('PGrange 'PGdate) where pgtype = daterange instance - ( UserType db ('PGcomposite row) ~ '(sch,td) - , Has sch db schema - , Has td schema ('Typedef ('PGcomposite row)) + ( relss ~ DbRelations db + , Has sch relss rels + , Has rel rels row + , FindQualified "no relation found with row:" relss row ~ '(sch,rel) ) => PGTyped db ('PGcomposite row) where - pgtype = typedef (QualifiedAlias @sch @td) + pgtype = typerow (QualifiedAlias @sch @rel) instance - ( UserType db ('PGenum labels) ~ '(sch,td) + ( enums ~ DbEnums db + , FindQualified "no enum found with labels:" enums labels ~ '(sch,td) , Has sch db schema , Has td schema ('Typedef ('PGenum labels)) ) => PGTyped db ('PGenum labels) where 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/Manipulation.hs b/src/Squeal/PostgreSQL/Manipulation.hs --- a/src/Squeal/PostgreSQL/Manipulation.hs +++ b/src/Squeal/PostgreSQL/Manipulation.hs @@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} diff --git a/src/Squeal/PostgreSQL/Manipulation/Call.hs b/src/Squeal/PostgreSQL/Manipulation/Call.hs --- a/src/Squeal/PostgreSQL/Manipulation/Call.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Call.hs @@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} diff --git a/src/Squeal/PostgreSQL/Manipulation/Delete.hs b/src/Squeal/PostgreSQL/Manipulation/Delete.hs --- a/src/Squeal/PostgreSQL/Manipulation/Delete.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Delete.hs @@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} diff --git a/src/Squeal/PostgreSQL/Manipulation/Insert.hs b/src/Squeal/PostgreSQL/Manipulation/Insert.hs --- a/src/Squeal/PostgreSQL/Manipulation/Insert.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Insert.hs @@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} diff --git a/src/Squeal/PostgreSQL/Manipulation/Update.hs b/src/Squeal/PostgreSQL/Manipulation/Update.hs --- a/src/Squeal/PostgreSQL/Manipulation/Update.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Update.hs @@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} 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 @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances @@ -323,7 +324,7 @@ >>> :{ let qry :: Query_ (Public Schema) (Int64, Bool) Row - qry = select Star (from (table #tab) & where_ (#col1 .> param @1 .&& notNull (param @2))) + qry = select Star (from (table #tab) & where_ (#col1 .> param @1 .&& just_ (param @2))) stmt :: Statement (Public Schema) (Int64, Bool) Row stmt = query qry :} @@ -353,7 +354,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 +365,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 +376,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 +387,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 +398,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 +409,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/From.hs b/src/Squeal/PostgreSQL/Query/From.hs --- a/src/Squeal/PostgreSQL/Query/From.hs +++ b/src/Squeal/PostgreSQL/Query/From.hs @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances diff --git a/src/Squeal/PostgreSQL/Query/From/Join.hs b/src/Squeal/PostgreSQL/Query/From/Join.hs --- a/src/Squeal/PostgreSQL/Query/From/Join.hs +++ b/src/Squeal/PostgreSQL/Query/From/Join.hs @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances diff --git a/src/Squeal/PostgreSQL/Query/From/Set.hs b/src/Squeal/PostgreSQL/Query/From/Set.hs --- a/src/Squeal/PostgreSQL/Query/From/Set.hs +++ b/src/Squeal/PostgreSQL/Query/From/Set.hs @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances diff --git a/src/Squeal/PostgreSQL/Query/Select.hs b/src/Squeal/PostgreSQL/Query/Select.hs --- a/src/Squeal/PostgreSQL/Query/Select.hs +++ b/src/Squeal/PostgreSQL/Query/Select.hs @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances 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 @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances @@ -230,11 +231,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/Values.hs b/src/Squeal/PostgreSQL/Query/Values.hs --- a/src/Squeal/PostgreSQL/Query/Values.hs +++ b/src/Squeal/PostgreSQL/Query/Values.hs @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances 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 @@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances @@ -36,11 +37,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 +141,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 +167,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 +176,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 +187,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 @@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} @@ -37,19 +38,21 @@ , withConnection ) where +import Control.Applicative import Control.Category +import Control.Monad (MonadPlus(..)) import Control.Monad.Base (MonadBase(..)) -import Control.Monad.Catch (MonadCatch(..), MonadThrow(..), MonadMask(..)) -import Control.Monad.Except +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Catch 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 ((<&>)) +import Data.Hashable import Data.Kind -import Data.Traversable +import Data.String import Generics.SOP import PostgreSQL.Binary.Encoding (encodingBytes) import Prelude hiding (id, (.)) @@ -60,6 +63,7 @@ import Squeal.PostgreSQL.Definition import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Session.Connection import Squeal.PostgreSQL.Session.Encode import Squeal.PostgreSQL.Session.Exception @@ -123,52 +127,62 @@ 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) executeParams (Query encode decode q) x = executeParams (Manipulation encode decode (queryStatement q)) x - 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 + prepare (Manipulation encode decode (UnsafeManipulation q :: Manipulation '[] db params row)) = do + let + statementNum = fromString $ case show (hash q) of + '-':num -> "negative_" <> num + num -> num + + prepName = "prepared_statement_" <> statementNum + + prepare' = PQ $ \ kconn@(K conn) -> liftIO $ do + let + 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 prepName (q <> ";") (Just oids) + case prepResultMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.prepare" + Just prepResult -> K <$> okResult_ prepResult + + deallocate' = manipulate_ . UnsafeManipulation $ + "DEALLOCATE" <+> prepName + + runPrepared' params = PQ $ \ kconn@(K conn) -> liftIO $ do encodedParams <- runReaderT (runEncodeParams encode params) kconn let formatParam encoding = (encodingBytes encoding, LibPQ.Binary) @@ -177,54 +191,18 @@ | maybeParam <- hcollapse encodedParams ] resultMaybe <- - LibPQ.execPrepared conn temp formattedParams LibPQ.Binary + LibPQ.execPrepared conn prepName formattedParams LibPQ.Binary case resultMaybe of - Nothing -> throwIO $ ConnectionException "LibPQ.execPrepared" + Nothing -> throwM $ ConnectionException "LibPQ.runPrepared" 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) - executePrepared (Query encode decode q) list = - executePrepared (Manipulation encode decode (queryStatement q)) list + return . K $ Result decode result - executePrepared_ (Manipulation encode _ (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 - 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 ()) - executePrepared_ (Query encode decode q) list = - executePrepared_ (Manipulation encode decode (queryStatement q)) list + prepare' + return $ Prepared runPrepared' deallocate' + prepare (Query encode decode q) = prepare (Manipulation encode decode (queryStatement q)) + instance (Monad m, db0 ~ db1) => Applicative (PQ db0 db1 m) where pure x = PQ $ \ _conn -> pure (K x) @@ -235,9 +213,9 @@ return = pure (>>=) = flip pqBind -instance (Monad m, db0 ~ db1) +instance (MonadFail m, db0 ~ db1) => Fail.MonadFail (PQ db0 db1 m) where - fail = Fail.fail + fail = lift . Fail.fail instance db0 ~ db1 => MFunctor (PQ db0 db1) where hoist f (PQ pq) = PQ (f . pq) @@ -317,16 +295,26 @@ instance (Monad m, Monoid r, db0 ~ db1) => Monoid (PQ db0 db1 m r) where mempty = pure mempty +instance MonadFix m => MonadFix (PQ db db m) where + mfix f = PQ $ \conn -> mfix $ \ (K a) -> K <$> evalPQ (f a) conn + +instance (Monad m, Alternative m, db0 ~ db1) + => Alternative (PQ db0 db1 m) where + empty = lift empty + altL <|> altR = PQ $ \ conn -> fmap K $ + evalPQ altL conn <|> evalPQ altR conn + +instance (MonadPlus m, db0 ~ db1) => MonadPlus (PQ db0 db1 m) + -- | 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 +325,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,12 +39,15 @@ , DecodeRow (..) , decodeRow , runDecodeRow - , genericRow + , GenericRow (..) + , genericProductRow , appendRows , consRow + , ArrayField (..) -- * Decoding Classes , FromValue (..) , FromField (..) + , FromAliasedValue (..) , FromArray (..) , StateT (..) , ExceptT (..) @@ -52,13 +57,23 @@ 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) +#if MIN_VERSION_postgresql_binary(0, 14, 0) +import Data.IP (IPRange) +#else +import Network.IP.Addr (NetAddr, IP) +#endif import Data.Kind import Data.Scientific (Scientific) import Data.String (fromString) @@ -69,7 +84,6 @@ import Database.PostgreSQL.LibPQ (Oid(Oid)) import GHC.OverloadedLabels import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) import PostgreSQL.Binary.Decoding hiding (Composite) import Unsafe.Coerce @@ -118,7 +132,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 @@ -191,8 +205,11 @@ fromPG = devalue $ Money <$> int instance FromPG UUID where fromPG = devalue uuid -instance FromPG (NetAddr IP) where - fromPG = devalue inet +#if MIN_VERSION_postgresql_binary(0, 14, 0) +instance FromPG IPRange where fromPG = devalue inet +#else +instance FromPG (NetAddr IP) where fromPG = devalue inet +#endif instance FromPG Char where fromPG = devalue char instance FromPG Strict.Text where @@ -229,6 +246,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,51 +514,158 @@ :: (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. +{- | Utility for decoding array fields in a `DecodeRow`, +accessed via overloaded labels. +-} +newtype ArrayField row y = ArrayField + { runArrayField + :: StateT Strict.ByteString (Except Strict.Text) y + -> DecodeRow row [y] + } +instance {-# OVERLAPPING #-} + ( KnownSymbol fld + , PG y ~ ty + , arr ~ 'NotNull ('PGvararray ('NotNull ty)) + ) => IsLabel fld (ArrayField (fld ::: arr ': row) y) where + fromLabel = ArrayField $ \yval -> + decodeRow $ \(SOP.K bytesMaybe SOP.:* _) -> do + let + flderr = mconcat + [ "field name: " + , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; " + ] + yarr + = devalue + . array + . dimensionArray replicateM + . valueArray + . revalue + $ yval + case bytesMaybe of + Nothing -> Left (flderr <> "encountered unexpected NULL") + Just bytes -> runExcept (evalStateT yarr bytes) +instance {-# OVERLAPPABLE #-} IsLabel fld (ArrayField row y) + => IsLabel fld (ArrayField (field ': row) y) where + fromLabel = ArrayField $ \yval -> + decodeRow $ \(_ SOP.:* bytess) -> + runDecodeRow (runArrayField (fromLabel @fld) yval) bytess +-- | 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 + ) => 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) runField + where + runField + :: forall ty z. FromField ty z + => SOP.K (Maybe Strict.ByteString) ty + -> (Except Strict.Text SOP.:.: SOP.P) z + runField + = SOP.Comp + . liftEither + . fromField @ty + . SOP.unK + +{- | Assistant class for `genericProductRow`, +this class forgets the name of a field while decoding it. +-} +class FromAliasedValue (field :: (Symbol, NullType)) (y :: Type) where + fromAliasedValue :: Maybe Strict.ByteString -> Either Strict.Text y +instance FromValue ty y => FromAliasedValue (fld ::: ty) y where + fromAliasedValue = fromValue @ty + +{- | Positionally `DecodeRow`. More general than `genericRow`, +which matches records both positionally and by field name, +`genericProductRow` matches records _or_ tuples purely positionally. + >>> 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 + decode :: DecodeRow '[ "foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGtext] (Int16, String) + decode = genericProductRow in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil) :} -Right (Two {frst = 2, scnd = "two"}) +Right (2,"two") -} -genericRow :: forall row y ys. - ( SOP.IsRecord y ys - , SOP.AllZip FromField row ys - ) => DecodeRow row y -genericRow +genericProductRow + :: ( SOP.IsProductType y ys + , SOP.AllZip FromAliasedValue row ys + ) + => DecodeRow row y +genericProductRow = DecodeRow . ReaderT - $ fmap SOP.fromRecord + $ fmap SOP.productTypeTo . 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 + . SOP.htrans (SOP.Proxy @FromAliasedValue) runField + where + runField + :: forall ty z. FromAliasedValue ty z + => SOP.K (Maybe Strict.ByteString) ty + -> (Except Strict.Text SOP.:.: SOP.I) z + runField + = SOP.Comp + . fmap SOP.I + . liftEither + . fromAliasedValue @ty + . SOP.unK {- | >>> :{ @@ -552,7 +682,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 @@ -11,6 +11,7 @@ {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds + , CPP , DataKinds , DefaultSignatures , FlexibleContexts @@ -24,17 +25,23 @@ , TypeFamilies , TypeOperators , UndecidableInstances + , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Session.Encode ( -- * Encode Parameters EncodeParams (..) - , genericParams + , GenericParams (..) , nilParams , (.*) , (*.) , aParam , appendParams + , enumParam + , rowParam + , genericRowParams + , (.#) + , (#.) -- * Encoding Classes , ToPG (..) , ToParam (..) @@ -48,8 +55,16 @@ 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) +#if MIN_VERSION_postgresql_binary(0, 14, 0) +import Data.IP (IPRange) +#else +import Network.IP.Addr (NetAddr, IP) +#endif import Data.Kind import Data.Scientific (Scientific) import Data.Text as Strict (Text) @@ -60,8 +75,7 @@ import Data.Word (Word32) import Foreign.C.Types (CUInt(CUInt)) import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) -import PostgreSQL.Binary.Encoding +import PostgreSQL.Binary.Encoding hiding (Composite, field) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as Lazy.ByteString @@ -112,7 +126,11 @@ instance ToPG db Scientific where toPG = pure . numeric instance ToPG db Money where toPG = pure . int8_int64 . cents instance ToPG db UUID where toPG = pure . uuid +#if MIN_VERSION_postgresql_binary(0, 14, 0) +instance ToPG db IPRange where toPG = pure . inet +#else instance ToPG db (NetAddr IP) where toPG = pure . inet +#endif instance ToPG db Char where toPG = pure . char_utf8 instance ToPG db Strict.Text where toPG = pure . text_strict instance ToPG db Lazy.Text where toPG = pure . text_lazy @@ -122,6 +140,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 @@ -194,25 +215,7 @@ , SOP.All (OidOfField db) fields , RowPG x ~ fields ) => ToPG db (Composite x) where - toPG (Composite x) = do - let - compositeSize - = int4_int32 - $ fromIntegral - $ SOP.lengthSList - $ SOP.Proxy @xs - each - :: OidOfField db field - => SOP.K (Maybe Encoding) field - -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding - each (SOP.K field :: SOP.K (Maybe Encoding) field) = do - oid <- getOid <$> oidOfField @db @field - return $ int4_word32 oid <> maybe null4 sized field - fields :: NP (SOP.K (Maybe Encoding)) fields <- hctransverse - (SOP.Proxy @(ToField db)) (toField @db) (SOP.toRecord x) - compositePayload <- hcfoldMapM - (SOP.Proxy @(OidOfField db)) each fields - return $ compositeSize <> compositePayload + toPG = rowParam (contramap getComposite genericRowParams) instance ToPG db x => ToPG db (Range x) where toPG r = do payload <- case r of @@ -309,7 +312,7 @@ {- | `EncodeParams` describes an encoding of a Haskell `Type` -into a list of parameter `NullType`s. +into a list of parameter `NullType`s or into a `RowType`. >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ @@ -322,53 +325,77 @@ :} K (Just "\NUL\SOH") :* K (Just "a") :* K (Just "foo") :* Nil +>>> :{ +let + encode :: EncodeParams '[] + '["fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)] + (Int16, Char) + encode = fst `as` #fst #. snd `as` #snd +in runReaderT (runEncodeParams encode (1,'a')) conn +:} +K (Just "\NUL\SOH") :* K (Just "a") :* Nil + >>> finish conn -} newtype EncodeParams (db :: SchemasType) - (tys :: [NullType]) + (tys :: [k]) (x :: Type) = EncodeParams { runEncodeParams :: x -> ReaderT (SOP.K LibPQ.Connection db) IO (NP (SOP.K (Maybe Encoding)) tys) } 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 +417,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 +442,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 +467,9 @@ >>> 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 + -- ^ a single parameter aParam = EncodeParams $ fmap (\param -> SOP.K param :* Nil) . toParam @db @(NullPG x) @@ -463,6 +495,145 @@ appendParams encode0 encode1 = EncodeParams $ \x -> also <$> runEncodeParams encode1 x <*> runEncodeParams encode0 x + +{- | +>>> :set -XLambdaCase -XFlexibleInstances +>>> :{ +data Dir = North | South | East | West +instance IsPG Dir where + type PG Dir = 'PGenum '["north", "south", "east", "west"] +instance ToPG db Dir where + toPG = enumParam $ \case + North -> label @"north" + South -> label @"south" + East -> label @"east" + West -> label @"west" +:} +-} +enumParam + :: (PG x ~ 'PGenum labels, SOP.All KnownSymbol labels) + => (x -> SOP.NS PGlabel labels) + -- ^ match cases with enum `label`s + -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding) +enumParam casesOf + = return + . text_strict + . Strict.Text.pack + . enumCases + . casesOf + where + enumCases + :: SOP.All KnownSymbol lbls + => SOP.NS PGlabel lbls + -> String + enumCases = \case + SOP.Z (_ :: PGlabel lbl) -> symbolVal (SOP.Proxy @lbl) + SOP.S cases -> enumCases cases + +{- | +>>> :set -XTypeFamilies -XFlexibleInstances +>>> :{ +data Complex = Complex + { real :: Double + , imaginary :: Double + } +instance IsPG Complex where + type PG Complex = 'PGcomposite '[ + "re" ::: 'NotNull 'PGfloat8, + "im" ::: 'NotNull 'PGfloat8] +instance ToPG db Complex where + toPG = rowParam $ real `as` #re #. imaginary `as` #im +:} +-} +rowParam + :: (PG x ~ 'PGcomposite row, SOP.All (OidOfField db) row) + => EncodeParams db row x + -- ^ use `(.#)` and `(#.)` to define a row parameter encoding + -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding) +rowParam (enc :: EncodeParams db row x) x = do + let + compositeSize + = int4_int32 + $ fromIntegral + $ SOP.lengthSList + $ SOP.Proxy @row + each + :: OidOfField db field + => SOP.K (Maybe Encoding) field + -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding + each (SOP.K field :: SOP.K (Maybe Encoding) field) = do + oid <- getOid <$> oidOfField @db @field + return $ int4_word32 oid <> maybe null4 sized field + fields <- runEncodeParams enc x + compositePayload <- hcfoldMapM + (SOP.Proxy @(OidOfField db)) each fields + return $ compositeSize <> compositePayload + +{- | Cons a row parameter encoding for `rowParam`. -} +(.#) + :: forall db x0 fld ty x tys. (ToParam db ty x0, ty ~ NullPG x0) + => Aliased ((->) x) (fld ::: x0) -- ^ head + -> EncodeParams db tys x -- ^ tail + -> EncodeParams db (fld ::: ty ': tys) x +(f `As` _) .# EncodeParams params = EncodeParams $ \x -> + (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x +infixr 5 .# + +{- | End a row parameter encoding for `rowParam`. -} +(#.) + :: forall db x x0 fld0 ty0 x1 fld1 ty1 + . ( ToParam db ty0 x0 + , ty0 ~ NullPG x0 + , ToParam db ty1 x1 + , ty1 ~ NullPG x1 + ) + => Aliased ((->) x) (fld0 ::: x0) -- ^ second to last + -> Aliased ((->) x) (fld1 ::: x1) -- ^ last + -> EncodeParams db '[fld0 ::: ty0, fld1 ::: ty1] x +f #. g = f .# g .# nilParams +infixl 8 #. + +instance (ToParam db ty x, ty ~ NullPG x) + => IsLabel fld (EncodeParams db '[fld ::: ty] x) where + fromLabel + = EncodeParams + $ fmap (\param -> SOP.K param :* Nil) + . toParam @db @(NullPG x) + +{- | +>>> import GHC.Generics as GHC +>>> :{ +data L = L {frst :: Int16, scnd :: Char} + deriving stock (GHC.Generic, Show) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +data R = R {thrd :: Bool, frth :: Bool} + deriving stock (GHC.Generic, Show) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +instance IsPG (L,R) where + type PG (L,R) = 'PGcomposite '[ + "frst" ::: 'NotNull 'PGint2, + "scnd" ::: 'NotNull ('PGchar 1), + "thrd" ::: 'NotNull 'PGbool, + "frth" ::: 'NotNull 'PGbool] +instance ToPG db (L,R) where + toPG = rowParam $ + contramap fst genericRowParams + `appendParams` + contramap snd genericRowParams +:} +-} +genericRowParams + :: forall db row x xs. + ( SOP.IsRecord x xs + , SOP.AllZip (ToField db) row xs + ) + => EncodeParams db row x +genericRowParams + = EncodeParams + $ hctransverse (SOP.Proxy @(ToField db)) (toField @db) + . SOP.toRecord + +-- helper functions getOid :: LibPQ.Oid -> Word32 getOid (LibPQ.Oid (CUInt oid)) = oid 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/Indexed.hs b/src/Squeal/PostgreSQL/Session/Indexed.hs --- a/src/Squeal/PostgreSQL/Session/Indexed.hs +++ b/src/Squeal/PostgreSQL/Session/Indexed.hs @@ -50,8 +50,8 @@ -} class ( forall i j m. Monad m => Functor (t i j m) - , forall i j m. (i ~ j, Monad m) => Monad (t i j m) - , forall i j. i ~ j => MonadTrans (t i j) + , forall i m. Monad m => Monad (t i i m) + , forall i. MonadTrans (t i i) ) => IndexedMonadTrans t where {-# MINIMAL pqJoin | pqBind #-} 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 @@ -11,31 +11,53 @@ {-# LANGUAGE DataKinds , DefaultSignatures + , DeriveFunctor , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs - , PolyKinds , MultiParamTypeClasses + , PolyKinds , QuantifiedConstraints , RankNTypes , TypeApplications , TypeFamilies + , TypeOperators , UndecidableInstances #-} -module Squeal.PostgreSQL.Session.Monad where +module Squeal.PostgreSQL.Session.Monad + ( -- * MonadPQ + MonadPQ (..) + -- * Manipulate + , manipulateParams + , manipulateParams_ + , manipulate + , manipulate_ + -- * Run Query + , runQueryParams + , runQuery + -- * Prepared + , executePrepared + , executePrepared_ + , traversePrepared + , forPrepared + , traversePrepared_ + , forPrepared_ + , preparedFor + ) where import Control.Category (Category (..)) import Control.Monad import Control.Monad.Morph +import Data.Foldable +import Data.Profunctor.Traversing +import Data.Traversable 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 @@ -165,13 +187,15 @@ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ execute_ silence :} -} - execute_ :: Statement db () () -> pq () + execute_ + :: Statement db () () + -- ^ query or manipulation + -> pq () execute_ = void . execute {- | - `executePrepared` runs a `Statement` on a `Traversable` - container by first preparing the statement, then running the prepared - statement on each element. + `prepare` creates a `Prepared` statement. When `prepare` is executed, + the specified `Statement` is parsed, analyzed, and rewritten. >>> import Data.Int (Int32, Int64) >>> import Data.Monoid (Sum(Sum)) @@ -184,32 +208,31 @@ ) `as` #getSum in withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do - results <- executePrepared sumOf [(2,2),(3,3),(4,4)] - traverse firstRow results + prepared <- prepare sumOf + result <- runPrepared prepared (2,2) + deallocate prepared + firstRow result :} - [Just (Sum {getSum = 4}),Just (Sum {getSum = 6}),Just (Sum {getSum = 8})] + Just (Sum {getSum = 4}) -} - executePrepared - :: Traversable list - => Statement db x y + prepare + :: Statement db x y -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq (list (Result y)) - default executePrepared + -> pq (Prepared pq x (Result y)) + default prepare :: (MonadTrans t, MonadPQ db m, pq ~ t m) - => Traversable list => Statement db x y -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq (list (Result y)) - executePrepared statement x = lift $ executePrepared statement x + -> pq (Prepared pq x (Result y)) + prepare statement = do + prepared <- lift $ prepare statement + return $ Prepared + (lift . runPrepared prepared) + (lift (deallocate prepared)) {- | - `executePrepared_` runs a returning-free `Statement` on a `Foldable` - container by first preparing the statement, then running the prepared - statement on each element. + `prepare_` creates a `Prepared` statement. When `prepare_` is executed, + the specified `Statement` is parsed, analyzed, and rewritten. >>> type Column = 'NoDef :=> 'NotNull 'PGint4 >>> type Columns = '["col1" ::: Column, "col2" ::: Column] @@ -227,33 +250,119 @@ ( notNullable int4 `as` #col1 :* notNullable int4 `as` #col2 ) Nil + session :: PQ DB DB IO () + session = do + prepared <- prepare_ insertion + runPrepared prepared (2,2) + deallocate prepared teardown :: Definition DB (Public '[]) teardown = dropTable #tab in withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup - & pqThen (executePrepared_ insertion [(2,2),(3,3),(4,4)]) + & pqThen session & pqThen (define teardown) :} -} - executePrepared_ - :: Foldable list - => Statement db x () - -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq () - default executePrepared_ - :: (MonadTrans t, MonadPQ db m, pq ~ t m) - => Foldable list - => Statement db x () + prepare_ + :: Statement db x () -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq () - executePrepared_ statement x = lift $ executePrepared_ statement x + -> pq (Prepared pq x ()) + prepare_ = fmap void . prepare {- | +* `prepare` a statement +* transforming its inputs and outputs with an optic, + run the `Prepared` statement +* deallocate the `Prepared` statement + +>>> :type preparedFor traverse' +preparedFor traverse' + :: (MonadPQ db pq, Traversable f) => + Statement db a b -> f a -> pq (f (Result b)) +-} +preparedFor + :: MonadPQ db pq + => (Prepared pq a (Result b) -> Prepared pq s t) + -- ^ transform the input and output + -> Statement db a b -- ^ query or manipulation + -> s -> pq t +preparedFor optic statement x' = do + prepared <- prepare statement + y' <- runPrepared (optic prepared) x' + deallocate prepared + return y' + +{- | +`executePrepared` runs a `Statement` on a `Traversable` +container by first preparing the statement, then running the prepared +statement on each element. + +>>> import Data.Int (Int32, Int64) +>>> import Data.Monoid (Sum(Sum)) +>>> :{ +let + sumOf :: Statement db (Int32, Int32) (Sum Int32) + sumOf = query $ values_ $ + ( param @1 @('NotNull 'PGint4) + + param @2 @('NotNull 'PGint4) + ) `as` #getSum +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do + results <- executePrepared sumOf [(2,2),(3,3),(4,4)] + traverse firstRow results +:} +[Just (Sum {getSum = 4}),Just (Sum {getSum = 6}),Just (Sum {getSum = 8})] +-} +executePrepared + :: (MonadPQ db pq, Traversable list) + => Statement db x y + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq (list (Result y)) +executePrepared = preparedFor traverse' + +{- | +`executePrepared_` runs a returning-free `Statement` on a `Foldable` +container by first preparing the statement, then running the prepared +statement on each element. + +>>> type Column = 'NoDef :=> 'NotNull 'PGint4 +>>> type Columns = '["col1" ::: Column, "col2" ::: Column] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> type DB = Public Schema +>>> import Data.Int(Int32) +>>> :{ +let + insertion :: Statement DB (Int32, Int32) () + insertion = manipulation $ insertInto_ #tab $ Values_ $ + Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* + Set (param @2 @('NotNull 'PGint4)) `as` #col2 + setup :: Definition (Public '[]) DB + setup = createTable #tab + ( notNullable int4 `as` #col1 :* + notNullable int4 `as` #col2 + ) Nil + teardown :: Definition DB (Public '[]) + teardown = dropTable #tab +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ + define setup + & pqThen (executePrepared_ insertion [(2,2),(3,3),(4,4)]) + & pqThen (define teardown) +:} +-} +executePrepared_ + :: (MonadPQ db pq, Foldable list) + => Statement db x () + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq () +executePrepared_ = preparedFor (wander traverse_) + +{- | `manipulateParams` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`. >>> type Column = 'NoDef :=> 'NotNull 'PGint4 @@ -426,8 +535,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 +561,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 +610,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 +660,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,11 @@ , OidOfField (..) ) where +import Control.Monad (when) +import Control.Monad.Catch (throwM) 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 @@ -142,80 +143,92 @@ instance OidOf db ('PGrange 'PGdate) where oidOf = pure $ LibPQ.Oid 3912 instance OidOfArray db ('PGrange 'PGdate) where oidOfArray = pure $ LibPQ.Oid 3913 instance - ( UserType db ('PGcomposite row) ~ '(sch,td) - , Has sch db schema - , Has td schema ('Typedef ('PGcomposite row)) ) - => OidOf db ('PGcomposite row) where - oidOf = oidOfTypedef (QualifiedAlias @sch @td) + ( KnownSymbol sch + , KnownSymbol td + , rels ~ DbRelations db + , FindQualified "no relation found with row:" rels row ~ '(sch,td) + ) => OidOf db ('PGcomposite row) where + oidOf = oidOfTypedef @sch @td instance - ( UserType db ('PGcomposite row) ~ '(sch,td) - , Has sch db schema - , Has td schema ('Typedef ('PGcomposite row)) ) - => OidOfArray db ('PGcomposite row) where - oidOfArray = oidOfArrayTypedef (QualifiedAlias @sch @td) + ( KnownSymbol sch + , KnownSymbol td + , rels ~ DbRelations db + , FindQualified "no relation found with row:" rels row ~ '(sch,td) + ) => OidOfArray db ('PGcomposite row) where + oidOfArray = oidOfArrayTypedef @sch @td instance - ( UserType db ('PGenum labels) ~ '(sch,td) - , Has sch db schema - , Has td schema ('Typedef ('PGenum labels)) ) - => OidOf db ('PGenum labels) where - oidOf = oidOfTypedef (QualifiedAlias @sch @td) + ( enums ~ DbEnums db + , FindQualified "no enum found with labels:" enums labels ~ '(sch,td) + , KnownSymbol sch + , KnownSymbol td + ) => OidOf db ('PGenum labels) where + oidOf = oidOfTypedef @sch @td instance - ( UserType db ('PGenum labels) ~ '(sch,td) - , Has sch db schema - , Has td schema ('Typedef ('PGenum labels)) ) - => OidOfArray db ('PGenum labels) where - oidOfArray = oidOfArrayTypedef (QualifiedAlias @sch @td) + ( enums ~ DbEnums db + , FindQualified "no enum found with labels:" enums labels ~ '(sch,td) + , KnownSymbol sch + , KnownSymbol td + ) => OidOfArray db ('PGenum labels) where + oidOfArray = oidOfArrayTypedef @sch @td oidOfTypedef - :: (Has sch db schema, Has ty schema pg) - => QualifiedAlias sch ty - -> ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -oidOfTypedef (_ :: QualifiedAlias sch ty) = ReaderT $ \(SOP.K conn) -> do + :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty) + => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +oidOfTypedef = 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 - :: (Has sch db schema, Has ty schema pg) - => QualifiedAlias sch ty - -> ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -oidOfArrayTypedef (_ :: QualifiedAlias sch ty) = ReaderT $ \(SOP.K conn) -> do + :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty) + => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +oidOfArrayTypedef = 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 @@ -31,7 +31,8 @@ -} {-# LANGUAGE - DeriveFunctor + CPP + , DeriveFunctor , FlexibleContexts , FlexibleInstances , InstanceSigs @@ -40,7 +41,8 @@ , RankNTypes , ScopedTypeVariables , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , UndecidableInstances #-} @@ -52,19 +54,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 +85,13 @@ -- 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 +#if MIN_VERSION_resource_pool(0,4,0) + liftIO . newPool $ setNumStripes + (Just stripes) + (defaultPoolConfig (connectdb conninfo) finish (realToFrac idle) maxResrc) +#else + liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc +#endif {-| Temporarily take a connection from a `Pool`, perform an action with it, @@ -95,11 +104,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 +132,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 @@ -23,31 +22,39 @@ #-} module Squeal.PostgreSQL.Session.Statement - ( Statement (..) + ( -- * Statement + Statement (..) , query , manipulation - , GenericParams - , GenericRow + -- * Prepared + , Prepared (..) ) where +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Monad +import Control.Monad.Fix import Data.Functor.Contravariant -import Data.Profunctor (Profunctor (..)) +import Data.Profunctor +import Data.Profunctor.Traversing +import GHC.Generics +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.Oid import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Render hiding ((<+>)) -- | A `Statement` consists of a `Squeal.PostgreSQL.Statement.Manipulation` -- or a `Squeal.PostgreSQL.Session.Statement.Query` that can be run -- in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. data Statement db x y where - -- | Constructor for a data manipulation language statement + -- | Constructor for a data manipulation language `Statement` Manipulation :: (SOP.All (OidOfNull db) params, SOP.SListI row) => EncodeParams db params x -- ^ encoding of parameters @@ -57,7 +64,7 @@ -- `Squeal.PostgreSQL.Manipulation.Update.update`, -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... -> Statement db x y - -- | Constructor for a structured query language statement + -- | Constructor for a structured query language `Statement` Query :: (SOP.All (OidOfNull db) params, SOP.SListI row) => EncodeParams db params x -- ^ encoding of parameters @@ -87,25 +94,7 @@ 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 +-- | Smart constructor for a structured query language `Statement` query :: ( GenericParams db params x xs , GenericRow row y ys @@ -115,7 +104,7 @@ -> Statement db x y query = Query genericParams genericRow --- | Smart constructor for a data manipulation language statement +-- | Smart constructor for a data manipulation language `Statement` manipulation :: ( GenericParams db params x xs , GenericRow row y ys @@ -125,3 +114,107 @@ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... -> Statement db x y manipulation = Manipulation genericParams genericRow + +{- | +`Squeal.PostgreSQL.Session.Monad.prepare` and +`Squeal.PostgreSQL.Session.Monad.prepare_` create a `Prepared` statement. +A `Prepared` statement is a server-side object +that can be used to optimize performance. +When `Squeal.PostgreSQL.Session.Monad.prepare` +or `Squeal.PostgreSQL.Session.Monad.prepare_` is executed, +the specified `Statement` is parsed, analyzed, and rewritten. + +When the `runPrepared` command is subsequently issued, +the `Prepared` statement is planned and executed. +This division of labor avoids repetitive parse analysis work, +while allowing the execution plan to +depend on the specific parameter values supplied. + +`Prepared` statements only last for the duration +of the current database session. +`Prepared` statements can be manually cleaned up +using the `deallocate` command. +-} +data Prepared m x y = Prepared + { runPrepared :: x -> m y -- ^ execute a prepared statement + , deallocate :: m () -- ^ manually clean up a prepared statement + } deriving (Functor, Generic, Generic1) + +instance Applicative m => Applicative (Prepared m x) where + pure a = Prepared (\_ -> pure a) (pure ()) + p1 <*> p2 = Prepared + (run2 (<*>) p1 p2) + (deallocate p1 *> deallocate p2) + +instance Alternative m => Alternative (Prepared m x) where + empty = Prepared (runKleisli empty) empty + p1 <|> p2 = Prepared + (run2 (<|>) p1 p2) + (deallocate p1 *> deallocate p2) + +instance Functor m => Profunctor (Prepared m) where + dimap g f prepared = Prepared + (fmap f . runPrepared prepared . g) + (deallocate prepared) + +instance Monad m => Strong (Prepared m) where + first' p = Prepared (run1 first' p) (deallocate p) + second' p = Prepared (run1 second' p) (deallocate p) + +instance Monad m => Choice (Prepared m) where + left' p = Prepared (run1 left' p) (deallocate p) + right' p = Prepared (run1 right' p) (deallocate p) + +instance MonadFix m => Costrong (Prepared m) where + unfirst p = Prepared (run1 unfirst p) (deallocate p) + unsecond p = Prepared (run1 unsecond p) (deallocate p) + +instance Monad m => Category (Prepared m) where + id = Prepared return (return ()) + cd . ab = Prepared + (runPrepared ab >=> runPrepared cd) + (deallocate ab >> deallocate cd) + +instance Monad m => Arrow (Prepared m) where + arr ab = Prepared (return . ab) (return ()) + first = first' + second = second' + ab *** cd = first ab >>> second cd + ab &&& ac = Prepared + (run2 (&&&) ab ac) + (deallocate ab >> deallocate ac) + +instance Monad m => ArrowChoice (Prepared m) where + left = left' + right = right' + ab +++ cd = left ab >>> right cd + bd ||| cd = Prepared + (run2 (|||) bd cd) + (deallocate bd >> deallocate cd) + +instance MonadFix m => ArrowLoop (Prepared m) where + loop p = Prepared (run1 loop p) (deallocate p) + +instance MonadPlus m => ArrowZero (Prepared m) where + zeroArrow = Prepared (runKleisli zeroArrow) (return ()) + +instance MonadPlus m => ArrowPlus (Prepared m) where + p1 <+> p2 = Prepared + (run2 (<+>) p1 p2) + (deallocate p1 >> deallocate p2) + +instance Monad m => Traversing (Prepared m) where + traverse' p = Prepared (run1 traverse' p) (deallocate p) + +-- helper functions + +run1 + :: (Kleisli m a b -> Kleisli m c d) + -> Prepared m a b -> c -> m d +run1 m = runKleisli . m . Kleisli . runPrepared + +run2 + :: (Kleisli m a b -> Kleisli m c d -> Kleisli m e f) + -> Prepared m a b -> Prepared m c d -> e -> m f +run2 (?) p1 p2 = runKleisli $ + Kleisli (runPrepared p1) ? Kleisli (runPrepared p2) 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 mode tx = Unsafe.transactionally mode tx -- | 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_ tx = Unsafe.transactionally_ tx {- | `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 mode tx = Unsafe.transactionallyRetry mode tx +{- | `transactionallyRetry` in `retryMode`. -} +transactionallyRetry_ + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => Transaction db x -- ^ run inside a transaction + -> tx x +transactionallyRetry_ tx = Unsafe.transactionallyRetry_ tx + {- | 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 mode tx = Unsafe.ephemerally mode tx {- | 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_ tx = Unsafe.ephemerally_ tx --- | 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 sv tx = Unsafe.withSavepoint sv tx 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,300 @@ +{-| +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 + , DataKinds + , PolyKinds +#-} + +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 @@ -26,14 +26,16 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Type - ( Money (..) + ( -- * Storage newtypes + Money (..) , Json (..) , Jsonb (..) , Composite (..) diff --git a/src/Squeal/PostgreSQL/Type/Alias.hs b/src/Squeal/PostgreSQL/Type/Alias.hs --- a/src/Squeal/PostgreSQL/Type/Alias.hs +++ b/src/Squeal/PostgreSQL/Type/Alias.hs @@ -27,7 +27,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilyDependencies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances , UndecidableSuperClasses @@ -53,11 +54,20 @@ -- * Grouping , Grouping (..) , GroupedBy + -- * Error reporting + , LookupFailedError + , PrettyPrintHaystack + , PrettyPrintInfo(..) + , MismatchError + , LookupFailedError' + , DefaultPrettyPrinter + , MismatchError' ) where import Control.DeepSeq import Data.ByteString (ByteString) import Data.String (fromString) +import GHC.Exts (Any, Constraint) import GHC.OverloadedLabels import GHC.TypeLits @@ -184,20 +194,91 @@ -- | @Has alias fields field@ is a constraint that proves that -- @fields@ has a field of @alias ::: field@, inferring @field@ -- from @alias@ and @fields@. -type Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) - = HasErr fields alias fields field +class (KnownSymbol alias) => Has (alias :: Symbol) (fields :: [(Symbol, kind)]) (field :: kind) | alias fields -> field +-- having these instances forces 'Has' to inspect 'alias' and 'fields' and thereby fail before delegating to +-- 'HasErr', which means 'Has' shows up in error messages instead of 'HasErr' +instance {-# OVERLAPPING #-} (KnownSymbol alias, HasErr (alias ::: field0 ': fields) alias (alias ::: field0 ': fields) field1) + => Has alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr (field' ': fields) alias (field' ': fields) field) + => Has alias (field' ': fields) field +instance (KnownSymbol alias, HasErr '[] alias '[] field) + => Has alias '[] field -{- | `HasErr` is like `Has` except it also retains the original +{- | 'HasErr' is like `Has` except it also retains the original list of fields being searched, so that error messages are more useful. -} class KnownSymbol alias => - HasErr err (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) + HasErr (allFields :: [(Symbol, kind)]) (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) | alias fields -> field where -instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1) - => HasErr err alias (alias ::: field0 ': fields) field1 -instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr err alias fields field) - => HasErr err alias (field' ': fields) field +instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1, MismatchError alias allFields field0 field1) + => HasErr allFields alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr allFields alias fields field) + => HasErr allFields alias (field' ': fields) field +instance ( KnownSymbol alias + , LookupFailedError alias allFields -- report a nicer error + , field ~ Any -- required to satisfy the fundep + ) => HasErr allFields alias '[] field + +-- | @MismatchError@ reports a nicer error with more context when we successfully do a lookup but +-- find a different field than we expected. As a type family, it ensures that we only do the (expensive) +-- calculation of coming up with our pretty printing information when we actually have a mismatch +type family MismatchError (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where + MismatchError _ _ found found = () + MismatchError alias fields found expected = MismatchError' (MismatchError' () (DefaultPrettyPrinter fields) alias fields found expected) (PrettyPrintHaystack fields) alias fields found expected + +-- | @MismatchError'@ is the workhorse behind @MismatchError@, but taking an additional type as the first argument. We can put another type error +-- in there which will only show if @MismatchError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance +-- is missing +type family MismatchError' (err :: Constraint) (ppInfo :: PrettyPrintInfo) (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where + MismatchError' _ ('PrettyPrintInfo needleName haystackName _) alias fields found expected = TypeError + ( 'Text "Type mismatch when looking up " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType alias + ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" + -- we don't use a pretty haystack because we want to show the values + ':$$: 'ShowType fields + ':$$: 'Text "" + ':$$: 'Text "Expected: " ':<>: 'ShowType expected + ':$$: 'Text "But found: " ':<>: 'ShowType found + ':$$: 'Text "" + ) + +-- | @LookupFailedError@ reports a nicer error when we fail to look up some @needle@ in some @haystack@ +type LookupFailedError needle haystack = LookupFailedError' (LookupFailedError' () (DefaultPrettyPrinter haystack) needle haystack) (PrettyPrintHaystack haystack) needle haystack + +-- | @LookupFailedError'@ is the workhorse behind @LookupFailedError@, but taking an additional type as the first argument. We can put another type error +-- in there which will only show if @LookupFailedError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance +-- is missing +type family LookupFailedError' (fallbackForUnknownKind :: Constraint) (prettyPrintInfo :: PrettyPrintInfo) (needle :: Symbol) (haystack :: [(Symbol, k)]) :: Constraint where + LookupFailedError' _ ('PrettyPrintInfo needleName haystackName prettyHaystack) needle rawHaystack = TypeError + ( 'Text "Could not find " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType needle + ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" + ':$$: prettyHaystack + ':$$: 'Text "" + ':$$: 'Text "*Raw " ':<>: haystackName ':<>: 'Text "*:" + ':$$: 'ShowType rawHaystack + ':$$: 'Text "" + ) + +-- | @PrettyPrintInfo@ is a data type intended to be used at the type level +-- which describes how to pretty print a haystack in our custom errors. The general intention is we use @PrettyPrintHaystack@ +-- to define a more specific way of pretty printing our error information for each kind that we care about +data PrettyPrintInfo = PrettyPrintInfo + { _needleName :: ErrorMessage + , _haystackName :: ErrorMessage + , _haystackPrettyPrint :: ErrorMessage + } + +-- | 'PrettyPrintHaystack' allows us to use the kind of our haystack to come up +-- with nicer errors. It is implemented as an open type family for dependency reasons +type family PrettyPrintHaystack (haystack :: [(Symbol, k)]) :: PrettyPrintInfo + +-- | @DefaultPrettyPrinter@ provides a default we can use for kinds that don't provide an instance of @PrettyPrintInfo@, +-- although that should generally only be accidental +type family DefaultPrettyPrinter (haystack :: [(Symbol, k)]) :: PrettyPrintInfo where + DefaultPrettyPrinter (haystack :: [(Symbol, k)]) = 'PrettyPrintInfo + ('Text "some kind without a PrettyPrintHaystack instance (" ':<>: 'ShowType k ':<>: 'Text ")") + ('Text "associative list of that kind ([(Symbol, " ':<>: 'ShowType k ':<>: 'Text ")])") + ('ShowType (Sort (MapFst haystack))) {-| @HasIn fields (alias ::: field)@ is a constraint that proves that @fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to 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 @@ -32,15 +32,25 @@ SOP.NP (..) , (*:) , one - , Join - , disjoin - , Additional (..) -- * Path , Path (..) -- * Type Level List + , Join + , disjoin + , Additional (..) , Elem , In , Length + , SubList + , SubsetList + -- * Type Level Sort + , Sort + , MergeSort + , Twos + , FoldMerge + , Merge + , MergeHelper + , MapFst ) where import Control.Category.Free @@ -107,3 +117,88 @@ 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 + +-- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order +type Sort ls = MergeSort (Twos ls) + +-- | 'MergeSort' is the workhorse behind 'Sort' +type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where + MergeSort '[] = '[] + MergeSort '[x] = x + MergeSort ls = MergeSort (FoldMerge ls) + +-- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end) +-- It is required for implementing 'MergeSort' +type family Twos (ls :: [k]) :: [[k]] where + Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs + Twos '[x] = '[ '[x]] + Twos '[] = '[] + +-- | 'Merge' two sorted lists into one list +type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where + Merge '[] r = r + Merge l '[] = l + Merge (l ': ls) (r ': rs) = MergeHelper (l ': ls) (r ': rs) (CmpSymbol l r) + +-- | 'MergeHelper' decides whether to take an element from the right or left list next, +-- depending on the result of their comparison +type family MergeHelper (ls :: [Symbol]) (rs :: [Symbol]) (cmp :: Ordering) where + MergeHelper ls (r ': rs) 'GT = r ': Merge ls rs + MergeHelper (l ': ls) rs leq = l ': Merge ls rs + +-- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list +type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where + FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs) + FoldMerge '[x] = '[x] + FoldMerge '[] = '[] + +-- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting +-- only the names in associatve lists +type family MapFst (ls :: [(j, k)]) :: [j] where + MapFst ('(j, _) ': rest) = j ': MapFst rest + MapFst '[] = '[] 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 @@ -10,6 +10,7 @@ -} {-# LANGUAGE AllowAmbiguousTypes + , CPP , DeriveAnyClass , DeriveFoldable , DeriveFunctor @@ -27,7 +28,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances , UndecidableSuperClasses @@ -52,14 +54,20 @@ ) 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) +#if MIN_VERSION_postgresql_binary(0, 14, 0) +import Data.IP (IPRange) +#else +import Network.IP.Addr (NetAddr, IP) +#endif import Data.Scientific (Scientific) import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime) import Data.Vector (Vector) import Data.UUID.Types (UUID) import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString as Strict (ByteString) @@ -163,13 +171,23 @@ -- | `PGuuid` instance IsPG UUID where type PG UUID = 'PGuuid -- | `PGinet` +#if MIN_VERSION_postgresql_binary(0, 14, 0) +instance IsPG IPRange where type PG IPRange = 'PGinet +#else instance IsPG (NetAddr IP) where type PG (NetAddr IP) = 'PGinet +#endif -- | `PGjson` instance IsPG Value where type PG Value = 'PGjson -- | `PGvarchar` 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 @@ -27,7 +27,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilyDependencies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances , UndecidableSuperClasses @@ -50,6 +51,10 @@ , SchemaType , SchemasType , Public + -- * Database Subsets + , SubDB + , SubsetDB + , ElemDB -- * Constraint , (:=>) , Optionality (..) @@ -95,10 +100,29 @@ , Updatable , AllUnique , IsNotElem - -- * User Types - , UserType - , UserTypeName - , UserTypeNamespace + -- * User Type Lookup + , DbEnums + , SchemaEnums + , DbRelations + , SchemaRelations + , FindQualified + , FindName + , FindNamespace + -- * Schema Error Printing + , PrettyPrintPartitionedSchema + , PartitionedSchema(..) + , PartitionSchema + , SchemaFunctions + , SchemaIndexes + , SchemaProcedures + , SchemaTables + , SchemaTypes + , SchemaUnsafes + , SchemaViews + , IntersperseNewlines + , FilterNonEmpty + , FieldIfNonEmpty + , PartitionSchema' ) where import Control.Category @@ -183,7 +207,7 @@ -- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the -- base `PGType` for a column. -- --- >>> :set -XTypeFamilies -XTypeInType +-- >>> :set -XTypeFamilies -XDataKinds -XPolyKinds -- >>> import GHC.TypeLits -- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4 -- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext @@ -200,6 +224,9 @@ -- :} type ColumnsType = [(Symbol,ColumnType)] +type instance PrettyPrintHaystack (haystack :: ColumnsType) = + 'PrettyPrintInfo ('Text "column definition (ColumnType)") ('Text "table (ColumnsType)") ('ShowType (Sort (MapFst haystack))) + -- | `TableConstraint` encodes various forms of data constraints -- of columns in a table. -- `TableConstraint`s give you as much control over the data in your tables @@ -221,6 +248,9 @@ -} type TableConstraints = [(Symbol,TableConstraint)] +type instance PrettyPrintHaystack (haystack :: TableConstraints) = + 'PrettyPrintInfo ('Text "constraint (TableConstraint)") ('Text "table (TableConstraints)") ('ShowType (Sort (MapFst haystack))) + -- | A `ForeignKey` must reference columns that either are -- a `PrimaryKey` or form a `Unique` constraint. type family Uniquely @@ -257,12 +287,18 @@ -} type RowType = [(Symbol,NullType)] +type instance PrettyPrintHaystack (haystack :: RowType) = + 'PrettyPrintInfo ('Text "column (NullType)") ('Text "row (RowType)") ('ShowType (Sort (MapFst haystack))) + {- | `FromType` is a row of `RowType`s. It can be thought of as a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.From.FromClause`s and `Squeal.PostgreSQL.Query.Table.TableExpression`s. -} type FromType = [(Symbol,RowType)] +type instance PrettyPrintHaystack (haystack :: FromType) = + 'PrettyPrintInfo ('Text "row (RowType)") ('Text "from clause (FromType)") ('ShowType (Sort (MapFst haystack))) + -- | `ColumnsToRow` removes column constraints. type family ColumnsToRow (columns :: ColumnsType) :: RowType where ColumnsToRow (column ::: _ :=> ty ': columns) = @@ -440,6 +476,41 @@ (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 ConstraintInvolves column ('Check columns) = column `Elem` columns @@ -532,6 +603,97 @@ -} type SchemaType = [(Symbol,SchemumType)] +-- | A @PartitionedSchema@ is a @SchemaType@ where each constructor of @SchemumType@ has +-- been separated into its own list +data PartitionedSchema = PartitionedSchema + { _tables :: [(Symbol, TableType)] + , _views :: [(Symbol, RowType)] + , _types :: [(Symbol, PGType)] + , _indexes :: [(Symbol, IndexType)] + , _functions :: [(Symbol, FunctionType)] + , _procedures :: [(Symbol, [NullType])] + , _unsafes :: [(Symbol, Symbol)] + } + +-- | @PartitionSchema@ partitions a @SchemaType@ into a @PartitionedSchema@ +type PartitionSchema schema = PartitionSchema' schema ('PartitionedSchema '[] '[] '[] '[] '[] '[] '[]) + +-- | Utility type family for `PartitionSchema`. +type family PartitionSchema' (remaining :: SchemaType) (acc :: PartitionedSchema) :: PartitionedSchema where + PartitionSchema' '[] ps = ps + PartitionSchema' ('(s, 'Table table) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema ('(s, table) ': tables) views types indexes functions procedures unsafe) + PartitionSchema' ('(s, 'View view) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables ('(s, view) ': views) types indexes functions procedures unsafe) + PartitionSchema' ('(s, 'Typedef typ) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views ('(s, typ) ': types) indexes functions procedures unsafe) + PartitionSchema' ('(s, 'Index ix) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types ('(s, ix) ': indexes) functions procedures unsafe) + PartitionSchema' ('(s, 'Function f) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes ('(s, f) ': functions) procedures unsafe) + PartitionSchema' ('(s, 'Procedure p) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions ('(s, p) ': procedures) unsafe) + PartitionSchema' ('(s, 'UnsafeSchemum u) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions procedures ('(s, u) ': unsafe)) + +-- | Get the tables from a @PartitionedSchema@ +type family SchemaTables (schema :: PartitionedSchema) :: [(Symbol, TableType)] where + SchemaTables ('PartitionedSchema tables _ _ _ _ _ _) = tables +-- | Get the views from a @PartitionedSchema@ +type family SchemaViews (schema :: PartitionedSchema) :: [(Symbol, RowType)] where + SchemaViews ('PartitionedSchema _ views _ _ _ _ _) = views +-- | Get the typedefs from a @PartitionedSchema@ +type family SchemaTypes (schema :: PartitionedSchema) :: [(Symbol, PGType)] where + SchemaTypes ('PartitionedSchema _ _ types _ _ _ _) = types +-- | Get the indexes from a @PartitionedSchema@ +type family SchemaIndexes (schema :: PartitionedSchema) :: [(Symbol, IndexType)] where + SchemaIndexes ('PartitionedSchema _ _ _ indexes _ _ _) = indexes +-- | Get the functions from a @PartitionedSchema@ +type family SchemaFunctions (schema :: PartitionedSchema) :: [(Symbol, FunctionType)] where + SchemaFunctions ('PartitionedSchema _ _ _ _ functions _ _) = functions +-- | Get the procedured from a @PartitionedSchema@ +type family SchemaProcedures (schema :: PartitionedSchema) :: [(Symbol, [NullType])] where + SchemaProcedures ('PartitionedSchema _ _ _ _ _ procedures _) = procedures +-- | Get the unsafe schema types from a @PartitionedSchema@ +type family SchemaUnsafes (schema :: PartitionedSchema) :: [(Symbol, Symbol)] where + SchemaUnsafes ('PartitionedSchema _ _ _ _ _ _ unsafes) = unsafes + +-- | @PrettyPrintPartitionedSchema@ makes a nice @ErrorMessage@ showing a @PartitionedSchema@, +-- only including the names of the things in it and not the values. Additionally, empty +-- fields are omitted +type family PrettyPrintPartitionedSchema (schema :: PartitionedSchema) :: ErrorMessage where + PrettyPrintPartitionedSchema schema = IntersperseNewlines (FilterNonEmpty + [ FieldIfNonEmpty "Tables" (SchemaTables schema) + , FieldIfNonEmpty "Views" (SchemaViews schema) + , FieldIfNonEmpty "Types" (SchemaTypes schema) + , FieldIfNonEmpty "Indexes" (SchemaIndexes schema) + , FieldIfNonEmpty "Functions" (SchemaFunctions schema) + , FieldIfNonEmpty "Procedures" (SchemaProcedures schema) + , FieldIfNonEmpty "Unsafe schema items" (SchemaUnsafes schema) + ]) + +-- | Print field name (if corresponding values are non-empty). +type family FieldIfNonEmpty (fieldName :: Symbol) (value :: [(Symbol, k)]) :: ErrorMessage where + FieldIfNonEmpty _ '[] = 'Text "" + FieldIfNonEmpty n xs = 'Text " " ':<>: 'Text n ':<>: 'Text ":" ':$$: 'Text " " ':<>: 'ShowType (Sort (MapFst xs)) + +-- | Filter out empty error messages. +type family FilterNonEmpty (ls :: [ErrorMessage]) :: [ErrorMessage] where + FilterNonEmpty ('Text "" ': rest) = FilterNonEmpty rest + FilterNonEmpty (x ': rest) = x ': FilterNonEmpty rest + FilterNonEmpty '[] = '[] + +-- | Vertically concatenate error messages. +type family IntersperseNewlines (ls :: [ErrorMessage]) :: ErrorMessage where + IntersperseNewlines (x ': y ': '[]) = x ':$$: y + IntersperseNewlines (x ': xs) = x ':$$: IntersperseNewlines xs + IntersperseNewlines '[] = 'Text "" + +type instance PrettyPrintHaystack (haystack :: SchemaType) = + 'PrettyPrintInfo ('Text "table, view, typedef, index, function, or procedure (SchemumType)") ('Text "schema (SchemaType)") + ( PrettyPrintPartitionedSchema (PartitionSchema haystack) + ) + {- | A database contains one or more named schemas, which in turn contain tables. The same object name can be used in different schemas without conflict; @@ -549,6 +711,9 @@ -} type SchemasType = [(Symbol,SchemaType)] +type instance PrettyPrintHaystack (haystack :: SchemasType) = + 'PrettyPrintInfo ('Text "schema (SchemaType)") ('Text "database (SchemasType)") ('Text " " ':<>: 'ShowType (Sort (MapFst haystack))) + -- | A type family to use for a single schema database. type family Public (schema :: SchemaType) :: SchemasType where Public schema = '["public" ::: schema] @@ -564,6 +729,12 @@ => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil instance IsPGlabel label (y -> K y label) where label = K instance IsPGlabel label (y -> NP (K y) '[label]) where label y = K y :* Nil +instance {-# OVERLAPPING #-} + IsPGlabel label0 (NS PGlabel (label0 ': labels)) where + label = Z PGlabel +instance {-# OVERLAPPABLE #-} IsPGlabel label0 (NS PGlabel labels) + => IsPGlabel label0 (NS PGlabel (label1 ': labels)) where + label = S (label @label0) -- | A `PGlabel` unit type with an `IsPGlabel` instance data PGlabel (label :: Symbol) = PGlabel instance KnownSymbol label => RenderSQL (PGlabel label) where @@ -599,24 +770,73 @@ , AllUnique columns , SListI (TableToColumns table) ) --- | Calculate the name of a user defined type. -type family UserTypeName (schema :: SchemaType) (ty :: PGType) where - UserTypeName '[] ty = 'Nothing - UserTypeName (td ::: 'Typedef ty ': _) ty = 'Just td - UserTypeName (_ ': schema) ty = UserTypeName schema ty +{- | Filters a schema down to labels of all enum typedefs. +-} +type family SchemaEnums schema where + SchemaEnums '[] = '[] + SchemaEnums (enum ::: 'Typedef ('PGenum labels) ': schema) = + enum ::: labels ': SchemaEnums schema + SchemaEnums (_ ': schema) = SchemaEnums schema --- | Helper to calculate the schema of a user defined type. -type family UserTypeNamespace - (sch :: Symbol) - (td :: Maybe Symbol) - (schemas :: SchemasType) - (ty :: PGType) where - UserTypeNamespace sch 'Nothing schemas ty = UserType schemas ty - UserTypeNamespace sch ('Just td) schemas ty = '(sch, td) +{- | Filters schemas down to labels of all enum typedefs. +-} +type family DbEnums db where + DbEnums '[] = '[] + DbEnums (sch ::: schema ': schemas) = + sch ::: SchemaEnums schema ': DbEnums schemas --- | Calculate the schema and name of a user defined type. -type family UserType (db :: SchemasType) (ty :: PGType) where - UserType '[] ty = TypeError - ('Text "No such user type: " ':<>: 'ShowType ty) - UserType (sch ::: schema ': schemas) ty = - UserTypeNamespace sch (UserTypeName schema ty) schemas ty +{- | Filters a schema down to rows of relations; +all composites, tables and views. +-} +type family SchemaRelations schema where + SchemaRelations '[] = '[] + SchemaRelations (ty ::: 'Typedef ('PGcomposite row) ': schema) = + ty ::: row ': SchemaRelations schema + SchemaRelations (tab ::: 'Table table ': schema) = + tab ::: TableToRow table ': SchemaRelations schema + SchemaRelations (vw ::: 'View row ': schema) = + vw ::: row ': SchemaRelations schema + SchemaRelations (_ ': schema) = SchemaRelations schema + +{- | Filters schemas down to rows of relations; +all composites, tables and views. +-} +type family DbRelations db where + DbRelations '[] = '[] + DbRelations (sch ::: schema ': schemas) = + sch ::: SchemaRelations schema ': DbRelations schemas + +-- | Used in `FindQualified` +type family FindName xs x where + FindName '[] xs = 'Nothing + FindName ( '(name, x) ': _) x = 'Just name + FindName (_ ': xs) x = FindName xs x + +-- | Used in `FindQualified` +type family FindNamespace err nsp name xss x where + FindNamespace err _ 'Nothing xss x = FindQualified err xss x + FindNamespace _ nsp ('Just name) _ _ = '(nsp, name) + +{- | Find fully qualified name with a type error if lookup fails. +This is used to find the qualified name of a user defined type. + +>>> :kind! FindQualified "my error message:" +FindQualified "my error message:" :: [(k1, [(k2, k3)])] + -> k3 -> (k1, k2) += FindQualified "my error message:" + +>>> :kind! FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Double +FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Double :: (Symbol, + Symbol) += '("foo", "bar") + +>>> :kind! FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Bool +FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Bool :: (Symbol, + Symbol) += (TypeError ...) +-} +type family FindQualified err xss x where + FindQualified err '[] x = TypeError + ('Text err ':$$: 'ShowType x) + FindQualified err ( '(nsp, xs) ': xss) x = + FindNamespace err nsp (FindName xs x) xss x diff --git a/test/Property.hs b/test/Property.hs --- a/test/Property.hs +++ b/test/Property.hs @@ -5,11 +5,14 @@ , DerivingStrategies , DerivingVia , FlexibleContexts + , FlexibleInstances , GADTs , LambdaCase + , MultiParamTypeClasses , OverloadedLabels , OverloadedStrings , ScopedTypeVariables + , StandaloneDeriving , TypeApplications , TypeOperators , UndecidableInstances @@ -20,6 +23,9 @@ import Control.Monad.Trans import Data.ByteString (ByteString) import Data.ByteString.Char8 (unpack) +import Data.Function (on) +import Data.Functor.Contravariant (contramap) +import Data.Int (Int16) import Data.Scientific (fromFloatDigits) import Data.Fixed (Fixed(MkFixed), Micro, Pico) import Data.String (IsString(fromString)) @@ -32,12 +38,13 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Main as Main import qualified Hedgehog.Range as Range +import Data.List (sort) main :: IO () main = withUtf8 $ do - withConnection connectionString $ define createSchwarma + withConnection connectionString $ define createDB Main.defaultMain [checkSequential roundtrips] - withConnection connectionString $ define dropSchwarma + withConnection connectionString $ define dropDB roundtrips :: Group roundtrips = Group "roundtrips" @@ -65,6 +72,9 @@ , roundtripOn normalizeIntRange daterange (genRange genDay) , roundtrip (typedef #schwarma) genSchwarma , roundtrip (vararray (typedef #schwarma)) genSchwarmaArray + , roundtrip (typerow #tab) genRow + , roundtrip (vararray (typetable #tab)) genRowArray + , ("table insert", roundtripTable) ] where genInt16 = Gen.int16 Range.exponentialBounded @@ -119,12 +129,17 @@ -- , "CDT", "MST", "MDT", "PST", "PDT" ] genSchwarma = Gen.enumBounded @_ @Schwarma genSchwarmaArray = VarArray <$> Gen.list (Range.constant 1 10) genSchwarma + genRow = HaskRow + <$> genInt16 + <*> Gen.enumBounded + <*> Gen.bool + genRowArray = VarArray <$> Gen.list (Range.constant 1 10) genRow roundtrip :: 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 +149,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 @@ -219,14 +234,83 @@ ch -> [ch] data Schwarma = Chicken | Lamb | Beef - deriving stock (Eq, Show, Bounded, Enum, GHC.Generic) + deriving stock (Eq, Ord, Show, Bounded, Enum, GHC.Generic) deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) deriving (IsPG, FromPG, ToPG db, Inline) via Enumerated Schwarma -type DB = '["public" ::: '["schwarma" ::: 'Typedef (PG Schwarma)]] +data HaskRow = HaskRow {foo :: Int16, bar :: Schwarma, baz :: Bool} + deriving stock (Eq, Ord, Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (IsPG, FromPG, Inline) via Composite HaskRow +deriving via Composite HaskRow + instance db ~ DB => ToPG db HaskRow -createSchwarma :: Definition '["public" ::: '[]] DB -createSchwarma = createTypeEnumFrom @Schwarma #schwarma +type Schema = '[ + "schwarma" ::: 'Typedef (PG Schwarma), + "tab" ::: 'Table ('[] :=> PGRow)] -dropSchwarma :: Definition DB '["public" ::: '[]] -dropSchwarma = dropType #schwarma +type DB = Public Schema + +type DB0 = Public '[] + +createDB :: Definition DB0 DB +createDB = + createTypeEnumFrom @Schwarma #schwarma >>> + createTable #tab + ( notNullable int2 `as` #foo :* + notNullable (typedef #schwarma) `as` #bar :* + notNullable bool `as` #baz + ) Nil + +dropDB :: Definition DB DB0 +dropDB = dropTable #tab >>> dropType #schwarma + +type PGRow = '[ + "foo" ::: 'NoDef :=> 'NotNull 'PGint2, + "bar" ::: 'NoDef :=> 'NotNull (PG Schwarma), + "baz" ::: 'NoDef :=> 'NotNull 'PGbool] + +insertTabInline :: [HaskRow] -> Statement DB () () +insertTabInline = \case + [] -> error "needs at least 1 row" + rw:rows -> manipulation $ insertInto_ #tab (inlineValues rw rows) + +insertTabParams :: Statement DB HaskRow () +insertTabParams = manipulation . insertInto_ #tab . Values_ $ + Set (param @1) `as` #foo :* + Set (param @2) `as` #bar :* + Set (param @3) `as` #baz + +insertTabUnnest :: Statement DB [HaskRow] () +insertTabUnnest = Manipulation enc dec sql + where + enc = contramap VarArray aParam + dec = return () + sql = insertInto_ #tab unnested + unnested = Select fields (from (unnest (param @1))) + fields = + Set (#unnest & field #tab #foo) `as` #foo :* + Set (#unnest & field #tab #bar) `as` #bar :* + Set (#unnest & field #tab #baz) `as` #baz + +selectTab :: Statement DB () HaskRow +selectTab = query $ select Star (from (table #tab)) + +roundtripTable :: Property +roundtripTable = property $ do + let + genInt16 = Gen.int16 Range.exponentialBounded + genRow = HaskRow + <$> genInt16 + <*> Gen.enumBounded + <*> Gen.bool + genRows = Gen.list (Range.constant 1 100) genRow + rows1 <- forAll genRows + rows2 <- forAll genRows + rows3 <- forAll genRows + tabRows <- lift . withConnection connectionString $ ephemerally_ $ do + execute_ (insertTabInline rows1) + executePrepared_ insertTabParams rows2 + executeParams_ insertTabUnnest rows3 + getRows =<< execute selectTab + ((===) `on` sort) tabRows (rows1 ++ rows2 ++ rows3) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,11 +10,13 @@ , MultiParamTypeClasses , OverloadedLabels , OverloadedStrings + , RankNTypes , StandaloneDeriving , TypeApplications , TypeFamilies , TypeSynonymInstances - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} @@ -107,7 +109,9 @@ let testUser = User "TestUser" - newUser = manipulateParams_ insertUser + newUser :: User -> Transaction DB () + newUser usr = manipulateParams_ insertUser usr + insertUserTwice :: Transaction DB () insertUserTwice = newUser testUser >> newUser testUser err23505 = UniqueViolation $ Char8.unlines [ "ERROR: duplicate key value violates unique constraint \"unique_names\"" @@ -129,12 +133,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" $