squeal-postgresql 0.7.0.1 → 0.9.2.0
raw patch · 63 files changed
Files
- README.md +1/−1
- bench/Gauge/DBHelpers.hs +2/−1
- exe/Example.hs +125/−11
- squeal-postgresql.cabal +10/−7
- src/Squeal/PostgreSQL.hs +5/−0
- src/Squeal/PostgreSQL/Definition.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Comment.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Constraint.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Function.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Index.hs +4/−3
- src/Squeal/PostgreSQL/Definition/Procedure.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Schema.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Table.hs +2/−1
- src/Squeal/PostgreSQL/Definition/Type.hs +2/−1
- src/Squeal/PostgreSQL/Definition/View.hs +2/−1
- src/Squeal/PostgreSQL/Expression.hs +6/−3
- src/Squeal/PostgreSQL/Expression/Aggregate.hs +51/−0
- src/Squeal/PostgreSQL/Expression/Array.hs +51/−2
- src/Squeal/PostgreSQL/Expression/Comparison.hs +4/−3
- src/Squeal/PostgreSQL/Expression/Composite.hs +9/−7
- src/Squeal/PostgreSQL/Expression/Inline.hs +59/−32
- src/Squeal/PostgreSQL/Expression/Json.hs +34/−12
- src/Squeal/PostgreSQL/Expression/Null.hs +21/−3
- src/Squeal/PostgreSQL/Expression/Parameter.hs +60/−8
- src/Squeal/PostgreSQL/Expression/Range.hs +2/−2
- src/Squeal/PostgreSQL/Expression/Subquery.hs +4/−2
- src/Squeal/PostgreSQL/Expression/Text.hs +23/−0
- src/Squeal/PostgreSQL/Expression/Time.hs +52/−1
- src/Squeal/PostgreSQL/Expression/Type.hs +36/−7
- src/Squeal/PostgreSQL/Expression/Window.hs +16/−0
- src/Squeal/PostgreSQL/Manipulation.hs +2/−1
- src/Squeal/PostgreSQL/Manipulation/Call.hs +2/−1
- src/Squeal/PostgreSQL/Manipulation/Delete.hs +2/−1
- src/Squeal/PostgreSQL/Manipulation/Insert.hs +2/−1
- src/Squeal/PostgreSQL/Manipulation/Update.hs +2/−1
- src/Squeal/PostgreSQL/Query.hs +9/−8
- src/Squeal/PostgreSQL/Query/From.hs +2/−1
- src/Squeal/PostgreSQL/Query/From/Join.hs +2/−1
- src/Squeal/PostgreSQL/Query/From/Set.hs +2/−1
- src/Squeal/PostgreSQL/Query/Select.hs +2/−1
- src/Squeal/PostgreSQL/Query/Table.hs +5/−3
- src/Squeal/PostgreSQL/Query/Values.hs +2/−1
- src/Squeal/PostgreSQL/Query/With.hs +85/−4
- src/Squeal/PostgreSQL/Session.hs +69/−81
- src/Squeal/PostgreSQL/Session/Decode.hs +160/−30
- src/Squeal/PostgreSQL/Session/Encode.hs +231/−60
- src/Squeal/PostgreSQL/Session/Exception.hs +16/−12
- src/Squeal/PostgreSQL/Session/Indexed.hs +2/−2
- src/Squeal/PostgreSQL/Session/Migration.hs +2/−2
- src/Squeal/PostgreSQL/Session/Monad.hs +158/−52
- src/Squeal/PostgreSQL/Session/Oid.hs +52/−39
- src/Squeal/PostgreSQL/Session/Pool.hs +25/−11
- src/Squeal/PostgreSQL/Session/Result.hs +122/−124
- src/Squeal/PostgreSQL/Session/Statement.hs +123/−30
- src/Squeal/PostgreSQL/Session/Transaction.hs +94/−191
- src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs +300/−0
- src/Squeal/PostgreSQL/Type.hs +5/−3
- src/Squeal/PostgreSQL/Type/Alias.hs +90/−9
- src/Squeal/PostgreSQL/Type/List.hs +98/−3
- src/Squeal/PostgreSQL/Type/PG.hs +20/−2
- src/Squeal/PostgreSQL/Type/Schema.hs +245/−25
- test/Property.hs +94/−10
- test/Spec.hs +9/−7
README.md view
@@ -2,7 +2,7 @@  -[](https://circleci.com/gh/morphismtech/squeal)+[](https://github.com/morphismtech/squeal/actions/workflows/ci.yml) [Github](https://github.com/morphismtech/squeal)
bench/Gauge/DBHelpers.hs view
@@ -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
exe/Example.hs view
@@ -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
squeal-postgresql.cabal view
@@ -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
src/Squeal/PostgreSQL.hs view
@@ -190,6 +190,11 @@ & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]++This should get you up and running with Squeal. Once you're writing more complicated+queries and need a deeper understanding of Squeal's types and how everything+fits together, check out the <https://github.com/morphismtech/squeal/blob/dev/squeal-core-concepts-handbook.md Core Concepts Handbook>+in the toplevel of Squeal's Git repo. -} module Squeal.PostgreSQL ( module X
src/Squeal/PostgreSQL/Definition.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses , UndecidableInstances
src/Squeal/PostgreSQL/Definition/Comment.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/Constraint.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/Function.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/Index.hs view
@@ -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 <> ";"
src/Squeal/PostgreSQL/Definition/Procedure.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/Schema.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/Table.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/Type.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Definition/View.hs view
@@ -24,7 +24,8 @@ , RankNTypes , ScopedTypeVariables , TypeApplications- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableSuperClasses #-}
src/Squeal/PostgreSQL/Expression.hs view
@@ -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)
src/Squeal/PostgreSQL/Expression/Aggregate.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Array.hs view
@@ -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"
src/Squeal/PostgreSQL/Expression/Comparison.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Composite.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Inline.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Json.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Null.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Parameter.hs view
@@ -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`.
src/Squeal/PostgreSQL/Expression/Range.hs view
@@ -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,
src/Squeal/PostgreSQL/Expression/Subquery.hs view
@@ -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))
src/Squeal/PostgreSQL/Expression/Text.hs view
@@ -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"
src/Squeal/PostgreSQL/Expression/Time.hs view
@@ -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"
src/Squeal/PostgreSQL/Expression/Type.hs view
@@ -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
src/Squeal/PostgreSQL/Expression/Window.hs view
@@ -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
src/Squeal/PostgreSQL/Manipulation.hs view
@@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances #-}
src/Squeal/PostgreSQL/Manipulation/Call.hs view
@@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances #-}
src/Squeal/PostgreSQL/Manipulation/Delete.hs view
@@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances #-}
src/Squeal/PostgreSQL/Manipulation/Insert.hs view
@@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances #-}
src/Squeal/PostgreSQL/Manipulation/Update.hs view
@@ -24,7 +24,8 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances #-}
src/Squeal/PostgreSQL/Query.hs view
@@ -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 $
src/Squeal/PostgreSQL/Query/From.hs view
@@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances
src/Squeal/PostgreSQL/Query/From/Join.hs view
@@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances
src/Squeal/PostgreSQL/Query/From/Set.hs view
@@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances
src/Squeal/PostgreSQL/Query/Select.hs view
@@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances
src/Squeal/PostgreSQL/Query/Table.hs view
@@ -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} {-----------------------------------------
src/Squeal/PostgreSQL/Query/Values.hs view
@@ -25,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances
src/Squeal/PostgreSQL/Query/With.hs view
@@ -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
src/Squeal/PostgreSQL/Session.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Decode.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Encode.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Exception.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Indexed.hs view
@@ -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 #-}
src/Squeal/PostgreSQL/Session/Migration.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Monad.hs view
@@ -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`,
src/Squeal/PostgreSQL/Session/Oid.hs view
@@ -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 <> "\'" , ";" ]
src/Squeal/PostgreSQL/Session/Pool.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Result.hs view
@@ -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
src/Squeal/PostgreSQL/Session/Statement.hs view
@@ -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)
src/Squeal/PostgreSQL/Session/Transaction.hs view
@@ -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
+ src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs view
@@ -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"
src/Squeal/PostgreSQL/Type.hs view
@@ -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 (..)
src/Squeal/PostgreSQL/Type/Alias.hs view
@@ -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
src/Squeal/PostgreSQL/Type/List.hs view
@@ -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 '[] = '[]
src/Squeal/PostgreSQL/Type/PG.hs view
@@ -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
src/Squeal/PostgreSQL/Type/Schema.hs view
@@ -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
test/Property.hs view
@@ -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)
test/Spec.hs view
@@ -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" $