diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # squeal-postgresql -![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif) +![squeal-icon](https://raw.githubusercontent.com/morphismtech/squeal/dev/squeal.gif) [![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal) diff --git a/bench/Gauge/DBHelpers.hs b/bench/Gauge/DBHelpers.hs --- a/bench/Gauge/DBHelpers.hs +++ b/bench/Gauge/DBHelpers.hs @@ -14,21 +14,14 @@ module Gauge.DBHelpers where -import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as C import qualified Data.Text as T import Control.Monad ( void ) -import Control.Monad.Except ( MonadIO - , throwError - ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Loops ( iterateWhile ) -import GHC.Generics ( Generic - , Generic1 - ) +import GHC.Generics ( Generic ) import Test.QuickCheck import Squeal.PostgreSQL -import qualified Data.ByteString.Char8 as C import Control.DeepSeq -- Project imports import Gauge.Schema ( Schemas ) diff --git a/bench/Gauge/DBSetup.hs b/bench/Gauge/DBSetup.hs --- a/bench/Gauge/DBSetup.hs +++ b/bench/Gauge/DBSetup.hs @@ -17,14 +17,12 @@ import qualified Data.ByteString.Char8 as C import Control.Monad ( void ) import GHC.Generics -import Test.QuickCheck import Squeal.PostgreSQL -- Project imports import Gauge.Schema ( Schemas , DeviceOS , IPLocation ) -import Gauge.Queries ( InsertUser ) -- First create enums as they're needed in the Schema @@ -59,7 +57,7 @@ ) ( primaryKey #id `as` #pk_user_devices - :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade + :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id :* unique #token `as` #token @@ -99,7 +97,7 @@ <> show portNumber connectionString :: ByteString -connectionString = "host=localhost port=5432 dbname=exampledb" +connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" performDBAction :: Definition a b -> String -> IO () performDBAction action message = do diff --git a/bench/Gauge/Queries.hs b/bench/Gauge/Queries.hs --- a/bench/Gauge/Queries.hs +++ b/bench/Gauge/Queries.hs @@ -21,11 +21,7 @@ import Data.Int ( Int16 , Int64 ) -import Test.QuickCheck ( Arbitrary(..) - , PrintableString(..) - , listOf - , arbitraryPrintableChar - ) +import Test.QuickCheck ( Arbitrary(..) ) import Generic.Random ( genericArbitrarySingle ) -- Import Orphan instances import Test.QuickCheck.Instances ( ) diff --git a/bench/Gauge/Schema.hs b/bench/Gauge/Schema.hs --- a/bench/Gauge/Schema.hs +++ b/bench/Gauge/Schema.hs @@ -72,7 +72,7 @@ type UserDevicesConstraints = '[ "pk_user_devices" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] , "token" ::: 'Unique '["token"] ] diff --git a/exe/Example.hs b/exe/Example.hs --- a/exe/Example.hs +++ b/exe/Example.hs @@ -9,7 +9,7 @@ , TypeOperators #-} -module Main (main, main2) where +module Main (main, main2, upsertUser) where import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32) @@ -22,7 +22,7 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC -type Schema = +type UserSchema = '[ "users" ::: 'Table ( '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 @@ -31,54 +31,96 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "user" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 , "email" ::: 'NoDef :=> 'Null 'PGtext ]) - , "positive" ::: 'Typedef 'PGfloat4 ] -type Schemas = Public Schema +type PublicSchema = '[ "positive" ::: 'Typedef 'PGfloat4 ] +type OrgSchema = + '[ "organizations" ::: 'Table ( + '[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ]) + , "members" ::: 'Table ( + '[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"] + , "fk_organization" ::: 'ForeignKey '["organization"] "org" "organizations" '["id"] ] :=> + '[ "member" ::: 'NoDef :=> 'NotNull 'PGint4 + , "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ]) + ] + +type Schemas + = '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ] + setup :: Definition (Public '[]) Schemas setup = - createTable #users + createDomain #positive real (#value .> 0 .&& (#value & isNotNull)) + >>> + createSchema #user + >>> + createSchema #org + >>> + createTable (#user ! #jokers) ( serial `as` #id :* (text & notNullable) `as` #name :* (vararray int2 & notNullable) `as` #vec ) ( primaryKey #id `as` #pk_users ) >>> - createTable #emails + alterTableRename (#user ! #jokers) #users + >>> + createTable (#user ! #emails) ( serial `as` #id :* columntypeFrom @Int32 `as` #user_id :* columntypeFrom @(Maybe Text) `as` #email ) ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) - >>> - createDomain #positive real (#value .> 0 .&& (#value & isNotNull)) - + foreignKey #user_id (#user ! #users) #id + (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) + >>> + createTable (#org ! #organizations) + ( serial `as` #id :* + (text & notNullable) `as` #name ) + ( primaryKey #id `as` #pk_organizations ) + >>> + createTable (#org ! #members) + ( notNullable int4 `as` #member :* + notNullable int4 `as` #organization ) + ( foreignKey #member (#user ! #users) #id + (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 >>> dropTable #emails >>> dropTable #users +teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32) -insertUser = insertInto #users +insertUser = insertInto (#user ! #users) (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly)) insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) () -insertEmail = insertInto_ #emails +insertEmail = insertInto_ (#user ! #emails) (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) getUsers :: Query_ Schemas () User getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) + ( from (table ((#user ! #users) `as` #u) + & innerJoin (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id)) ) +upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) () +upsertUser = insertInto (#user ! #users `as` #u) + (Values_ (Set (param @1) `as` #id :* setUser)) + (OnConflict (OnConstraint #pk_users) (DoUpdate setUser [#u ! #id .== param @1])) + (Returning_ Nil) + where + setUser = Set (param @2) `as` #name :* Set (param @3) `as` #vec :* Nil + data User = User { userName :: Text @@ -110,7 +152,7 @@ main = do Char8.putStrLn "squeal" connectionString <- pure - "host=localhost port=5432 dbname=exampledb" + "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Char8.putStrLn $ "connecting to " <> connectionString connection0 <- connectdb connectionString Char8.putStrLn "setting up schema" @@ -122,7 +164,7 @@ main2 :: IO () main2 = - withConnection "host=localhost port=5432 dbname=exampledb" $ + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup & pqThen session & pqThen (define teardown) diff --git a/squeal-postgresql.cabal b/squeal-postgresql.cabal --- a/squeal-postgresql.cabal +++ b/squeal-postgresql.cabal @@ -1,5 +1,5 @@ name: squeal-postgresql -version: 0.6.0.2 +version: 0.7.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal @@ -23,11 +23,13 @@ exposed-modules: Squeal.PostgreSQL Squeal.PostgreSQL.Definition + Squeal.PostgreSQL.Definition.Comment Squeal.PostgreSQL.Definition.Constraint Squeal.PostgreSQL.Definition.Function Squeal.PostgreSQL.Definition.Index Squeal.PostgreSQL.Definition.Table Squeal.PostgreSQL.Definition.Type + Squeal.PostgreSQL.Definition.Procedure Squeal.PostgreSQL.Definition.Schema Squeal.PostgreSQL.Definition.View Squeal.PostgreSQL.Expression @@ -51,6 +53,7 @@ Squeal.PostgreSQL.Expression.Type Squeal.PostgreSQL.Expression.Window Squeal.PostgreSQL.Manipulation + Squeal.PostgreSQL.Manipulation.Call Squeal.PostgreSQL.Manipulation.Delete Squeal.PostgreSQL.Manipulation.Insert Squeal.PostgreSQL.Manipulation.Update @@ -84,31 +87,34 @@ default-language: Haskell2010 ghc-options: -Wall build-depends: - aeson >= 1.2.4.0 - , base >= 4.11.1.0 && < 5.0 - , binary >= 0.8.6.0 + aeson >= 1.4.7.1 + , base >= 4.13.0.0 && < 5.0 + , binary >= 0.8.7.0 , binary-parser >= 0.5.5 - , bytestring >= 0.10.8.2 - , bytestring-strict-builder >= 0.4.5 - , deepseq >= 1.4.3.0 + , bytestring >= 0.10.10.0 + , bytestring-strict-builder >= 0.4.5.3 + , deepseq >= 1.4.4.0 + , exceptions >= 0.10.3 , free-categories >= 0.2.0.0 - , generics-sop >= 0.3.2.0 - , mmorph >= 1.1.1 + , generics-sop >= 0.5.1.0 + , mmorph >= 1.1.3 + , monad-control >= 1.0.2.3 , mtl >= 2.2.2 - , network-ip >= 0.3.0.2 - , postgresql-binary >= 0.12.1 - , postgresql-libpq >= 0.9.4.1 - , profunctors >= 5.3 - , records-sop >= 0.1.0.0 + , network-ip >= 0.3.0.3 + , postgresql-binary >= 0.12.2 + , postgresql-libpq >= 0.9.4.2 + , profunctors >= 5.5.2 + , records-sop >= 0.1.0.3 , resource-pool >= 0.2.3.2 - , scientific >= 0.3.5.3 - , text >= 1.2.3.0 - , time >= 1.8.0.2 - , transformers >= 0.5.2.0 - , unliftio >= 0.2.10 - , unliftio-pool >= 0.2.1.0 + , scientific >= 0.3.6.2 + , text >= 1.2.3.2 + , time >= 1.9.3 + , 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.0.1 + , vector >= 0.12.1.2 test-suite doctest default-language: Haskell2010 @@ -117,8 +123,8 @@ ghc-options: -Wall main-is: Doc.hs build-depends: - base >= 4.10.0.0 - , doctest >= 0.11.4 + base >= 4.13.0.0 && < 5.0 + , doctest >= 0.16.3 , squeal-postgresql test-suite properties @@ -128,13 +134,14 @@ ghc-options: -Wall main-is: Property.hs build-depends: - base >= 4.10.0.0 - , bytestring >= 0.10.8.2 - , hedgehog >= 1.0 + base >= 4.13.0.0 && < 5.0 + , bytestring >= 0.10.10.0 + , hedgehog >= 1.0.2 + , generics-sop >= 0.5.1.0 , mtl >= 2.2.2 - , scientific >= 0.3.5.3 + , scientific >= 0.3.6.2 , squeal-postgresql - , time >= 1.8.0.2 + , time >= 1.9.3 , with-utf8 >= 1.0 test-suite spec @@ -145,14 +152,14 @@ main-is: Spec.hs build-depends: async >= 2.2.2 - , base >= 4.10.0.0 - , bytestring >= 0.10.8.2 - , generics-sop >= 0.3.1.0 - , hspec >= 2.4.8 + , base >= 4.13.0.0 && < 5.0 + , bytestring >= 0.10.10.0 + , generics-sop >= 0.5.1.0 + , hspec >= 2.7.1 , mtl >= 2.2.2 , squeal-postgresql - , text >= 1.2.2.2 - , vector >= 0.12.0.1 + , text >= 1.2.3.2 + , vector >= 0.12.1.2 benchmark gauge type: exitcode-stdio-1.0 @@ -171,19 +178,19 @@ -rtsopts -funbox-strict-fields build-depends: - base >= 4.10.0.0 - , bytestring >= 0.10.8.2 - , deepseq >= 1.4.3.0 + base >= 4.13.0.0 && < 5.0 + , bytestring >= 0.10.10.0 + , deepseq >= 1.4.4.0 , gauge >= 0.2.5 - , generic-random >= 1.2.0.0 - , generics-sop >= 0.3.1.0 + , generic-random >= 1.3.0.1 + , generics-sop >= 0.5.1.0 , monad-loops >= 0.4.3 , mtl >= 2.2.2 , QuickCheck >= 2.13.2 , quickcheck-instances >= 0.3.22 - , scientific >= 0.3.5.3 + , scientific >= 0.3.6.2 , squeal-postgresql - , text >= 1.2.2.2 + , text >= 1.2.3.2 , with-utf8 >= 1.0 executable example @@ -193,10 +200,10 @@ main-is: Example.hs build-depends: base >= 4.10.0.0 && < 5.0 - , bytestring >= 0.10.8.2 - , generics-sop >= 0.3.1.0 - , mtl >= 2.2.1 + , bytestring >= 0.10.10.0 + , generics-sop >= 0.5.1.0 + , mtl >= 2.2.2 , squeal-postgresql - , text >= 1.2.2.2 - , transformers >= 0.5.2.0 - , vector >= 0.12.0.1 + , text >= 1.2.3.2 + , transformers >= 0.5.6.2 + , vector >= 0.12.1.2 diff --git a/src/Squeal/PostgreSQL.hs b/src/Squeal/PostgreSQL.hs --- a/src/Squeal/PostgreSQL.hs +++ b/src/Squeal/PostgreSQL.hs @@ -40,7 +40,7 @@ , "email" ::: 'NoDef :=> 'Null 'PGtext ] type EmailsConstraints = '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] type Schema = '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ] @@ -78,7 +78,7 @@ (text & nullable) `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) + (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) :} We can easily see the generated SQL is unsurprising looking. @@ -136,7 +136,7 @@ :} >>> printSQL insertUser -WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u" +WITH "u" AS (INSERT INTO "users" AS "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" AS "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u" Next we write a `Statement` to retrieve users from the database. We're not interested in the ids here, just the usernames and email addresses. We @@ -184,7 +184,7 @@ usersRows <- getRows usersResult liftIO $ print usersRows in - withConnection "host=localhost port=5432 dbname=exampledb" $ + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup & pqThen session & pqThen (define teardown) @@ -198,9 +198,11 @@ ) where import Squeal.PostgreSQL.Definition as X +import Squeal.PostgreSQL.Definition.Comment as X import Squeal.PostgreSQL.Definition.Constraint as X import Squeal.PostgreSQL.Definition.Function as X import Squeal.PostgreSQL.Definition.Index as X +import Squeal.PostgreSQL.Definition.Procedure as X import Squeal.PostgreSQL.Definition.Schema as X import Squeal.PostgreSQL.Definition.Table as X import Squeal.PostgreSQL.Definition.Type as X @@ -226,6 +228,7 @@ import Squeal.PostgreSQL.Expression.Type as X import Squeal.PostgreSQL.Expression.Window as X import Squeal.PostgreSQL.Manipulation as X +import Squeal.PostgreSQL.Manipulation.Call as X import Squeal.PostgreSQL.Manipulation.Delete as X import Squeal.PostgreSQL.Manipulation.Insert as X import Squeal.PostgreSQL.Manipulation.Update as X diff --git a/src/Squeal/PostgreSQL/Definition/Comment.hs b/src/Squeal/PostgreSQL/Definition/Comment.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Comment.hs @@ -0,0 +1,165 @@ +{- | +Module: Squeal.PostgreSQL.Definition.Constraint +Description: comments +Copyright: (c) Eitan Chatav, 2020 +Maintainer: eitan@morphism.tech +Stability: experimental + +comments +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeInType + , TypeOperators + , UndecidableSuperClasses + #-} + +module Squeal.PostgreSQL.Definition.Comment + ( commentOnTable + , commentOnType + , commentOnView + , commentOnFunction + , commentOnIndex + , commentOnColumn + , commentOnSchema + ) where + +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema +import GHC.TypeLits (KnownSymbol) +import Data.Text (Text) + +{----------------------------------------- +COMMENT statements +-----------------------------------------} + +{- | +When a user views a table in the database (i.e. with \d+ ), it is useful +to be able to read a description of the table. +-} +commentOnTable + :: ( KnownSymbol sch + , KnownSymbol tab + , Has sch db schema + , Has tab schema ('Table table) + ) + => QualifiedAlias sch tab -- ^ table + -> Text -- ^ comment + -> Definition db db +commentOnTable alias comm = UnsafeDefinition $ + "COMMENT ON TABLE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" + +{- | +When a user views a type in the database (i.e with \dT ), it is useful to +be able to read a description of the type. +-} +commentOnType + :: ( KnownSymbol sch + , KnownSymbol typ + , Has sch db schema + , Has typ schema ('Typedef type_) + ) + => QualifiedAlias sch typ -- ^ type + -> Text -- ^ comment + -> Definition db db +commentOnType alias comm = UnsafeDefinition $ + "COMMENT ON TYPE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" + +{- | +When a user views a view in the database (i.e. with \dv ), it is useful +to be able to read a description of the view. +-} +commentOnView + :: ( KnownSymbol sch + , KnownSymbol vie + , Has sch db schema + , Has vie schema ('View view) + ) + => QualifiedAlias sch vie -- ^ view + -> Text -- ^ comment + -> Definition db db +commentOnView alias comm = UnsafeDefinition $ + "COMMENT ON VIEW" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" + +{- | +When a user views an index in the database (i.e. with \di+ ), it is +useful to be able to read a description of the index. +-} +commentOnIndex + :: ( KnownSymbol sch + , KnownSymbol ind + , Has sch db schema + , Has ind schema ('Index index) + ) + => QualifiedAlias sch ind -- ^ index + -> Text -- ^ comment + -> Definition db db +commentOnIndex alias comm = UnsafeDefinition $ + "COMMENT ON INDEX" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" + +{- | +When a user views a function in the database (i.e. with \df+ ), it is +useful to be able to read a description of the function. +-} +commentOnFunction + :: ( KnownSymbol sch + , KnownSymbol fun + , Has sch db schema + , Has fun schema ('Function function) + ) + => QualifiedAlias sch fun -- ^ function + -> Text -- ^ comment + -> Definition db db +commentOnFunction alias comm = UnsafeDefinition $ + "COMMENT ON FUNCTION" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" + +{- | +When a user views a table in the database (i.e. with \d+
), it is useful +to be able to view descriptions of the columns in that table. +-} +commentOnColumn + :: ( KnownSymbol sch + , KnownSymbol tab + , KnownSymbol col + , Has sch db schema + , Has tab schema ('Table '(cons, cols)) + , Has col cols '(def, nulltyp) + ) + => QualifiedAlias sch tab -- ^ table + -> Alias col -- ^ column + -> Text -- ^ comment + -> Definition db db +commentOnColumn table col comm = UnsafeDefinition $ + "COMMENT ON COLUMN" <+> renderSQL table <> "." <> renderSQL col <+> "IS" + <+> singleQuotedText comm <> ";" + +{- | +When a user views a schema in the database (i.e. with \dn+ ), it is +useful to be able to read a description. +-} +commentOnSchema + :: ( KnownSymbol sch + , Has sch db schema + ) + => Alias sch -- ^ schema + -> Text -- ^ comment + -> Definition db db +commentOnSchema schema comm = UnsafeDefinition $ + "COMMENT ON SCHEMA" <+> renderSQL schema <> "IS" <+> singleQuotedText comm <> ";" diff --git a/src/Squeal/PostgreSQL/Definition/Constraint.hs b/src/Squeal/PostgreSQL/Definition/Constraint.hs --- a/src/Squeal/PostgreSQL/Definition/Constraint.hs +++ b/src/Squeal/PostgreSQL/Definition/Constraint.hs @@ -40,6 +40,7 @@ , ForeignKeyed , OnDeleteClause (..) , OnUpdateClause (..) + , ReferentialAction (..) ) where import Control.DeepSeq @@ -200,7 +201,7 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 @@ -223,7 +224,7 @@ (text & nullable) `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) + (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) in printSQL setup :} CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); @@ -235,7 +236,7 @@ type Schema = '[ "employees" ::: 'Table ( '[ "employees_pk" ::: 'PrimaryKey '["id"] - , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"] + , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "public" "employees" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext @@ -254,20 +255,23 @@ (integer & nullable) `as` #employer_id ) ( primaryKey #id `as` #employees_pk :* foreignKey #employer_id #employees #id - OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk ) + (OnDelete Cascade) (OnUpdate Cascade) `as` #employees_employer_fk ) in printSQL setup :} CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE); -} foreignKey - :: (ForeignKeyed db sch schema child parent + :: (ForeignKeyed db + sch0 sch1 + schema0 schema1 + child parent table reftable columns refcolumns constraints cols reftys tys ) => NP Alias columns -- ^ column or columns in the table - -> Alias parent + -> QualifiedAlias sch0 parent -- ^ reference table -> NP Alias refcolumns -- ^ reference column or columns in the reference table @@ -275,8 +279,8 @@ -- ^ what to do when reference is deleted -> OnUpdateClause -- ^ what to do when reference is updated - -> TableConstraintExpression sch child db - ('ForeignKey columns parent refcolumns) + -> TableConstraintExpression sch1 child db + ('ForeignKey columns sch0 parent refcolumns) foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ "FOREIGN KEY" <+> parenthesized (renderSQL keys) <+> "REFERENCES" <+> renderSQL parent @@ -286,16 +290,17 @@ -- | A constraint synonym between types involved in a foreign key constraint. type ForeignKeyed db - sch - schema + sch0 sch1 + schema0 schema1 child parent table reftable columns refcolumns constraints cols reftys tys = - ( Has sch db schema - , Has child schema ('Table table) - , Has parent schema ('Table reftable) + ( Has sch0 db schema0 + , Has sch1 db schema1 + , Has parent schema0 ('Table reftable) + , Has child schema1 ('Table table) , HasAll columns (TableToColumns table) tys , reftable ~ (constraints :=> cols) , HasAll refcolumns cols reftys @@ -303,39 +308,44 @@ , Uniquely refcolumns constraints ) -- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. -data OnDeleteClause - = OnDeleteNoAction - -- ^ if any referencing rows still exist when the constraint is checked, - -- an error is raised - | OnDeleteRestrict -- ^ prevents deletion of a referenced row - | OnDeleteCascade - -- ^ specifies that when a referenced row is deleted, - -- row(s) referencing it should be automatically deleted as well +newtype OnDeleteClause = OnDelete ReferentialAction deriving (GHC.Generic,Show,Eq,Ord) instance NFData OnDeleteClause --- | Render `OnDeleteClause`. instance RenderSQL OnDeleteClause where - renderSQL = \case - OnDeleteNoAction -> "ON DELETE NO ACTION" - OnDeleteRestrict -> "ON DELETE RESTRICT" - OnDeleteCascade -> "ON DELETE CASCADE" + renderSQL (OnDelete action) = "ON DELETE" <+> renderSQL action -- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked -- when a referenced column is changed (updated). -data OnUpdateClause - = OnUpdateNoAction - -- ^ if any referencing rows has not changed when the constraint is checked, - -- an error is raised - | OnUpdateRestrict -- ^ prevents update of a referenced row - | OnUpdateCascade - -- ^ the updated values of the referenced column(s) should be copied - -- into the referencing row(s) +newtype OnUpdateClause = OnUpdate ReferentialAction deriving (GHC.Generic,Show,Eq,Ord) instance NFData OnUpdateClause - --- | Render `OnUpdateClause`. instance RenderSQL OnUpdateClause where + renderSQL (OnUpdate action) = "ON UPDATE" <+> renderSQL action + +{- | When the data in the referenced columns is changed, +certain actions are performed on the data in this table's columns.-} +data ReferentialAction + = NoAction + {- ^ Produce an error indicating that the deletion or update + would create a foreign key constraint violation. + If the constraint is deferred, this error will be produced + at constraint check time if there still exist any referencing rows.-} + | Restrict + {- ^ Produce an error indicating that the deletion or update + would create a foreign key constraint violation. + This is the same as `NoAction` except that the check is not deferrable.-} + | Cascade + {- ^ Delete any rows referencing the deleted row, + or update the value of the referencing column + to the new value of the referenced column, respectively.-} + | SetNull {- ^ Set the referencing column(s) to null.-} + | SetDefault {- ^ Set the referencing column(s) to their default values.-} + deriving (GHC.Generic,Show,Eq,Ord) +instance NFData ReferentialAction +instance RenderSQL ReferentialAction where renderSQL = \case - OnUpdateNoAction -> "ON UPDATE NO ACTION" - OnUpdateRestrict -> "ON UPDATE RESTRICT" - OnUpdateCascade -> "ON UPDATE CASCADE" + NoAction -> "NO ACTION" + Restrict -> "RESTRICT" + Cascade -> "CASCADE" + SetNull -> "SET NULL" + SetDefault -> "SET DEFAULT" diff --git a/src/Squeal/PostgreSQL/Definition/Procedure.hs b/src/Squeal/PostgreSQL/Definition/Procedure.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Procedure.hs @@ -0,0 +1,171 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Procedure +Description: create and drop procedures +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create and drop procedures +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeInType + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Procedure + ( -- * Create + createProcedure + , createOrReplaceProcedure + -- * Drop + , dropProcedure + , dropProcedureIfExists + -- * Procedure Definition + , ProcedureDefinition(..) + , languageSqlManipulation + ) where + +import Control.DeepSeq +import Data.ByteString +import GHC.TypeLits + +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | Create a procedure. + +>>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ] +>>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) +>>> :{ +let + definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc]) + definition = createProcedure #proc (one int4) + . languageSqlManipulation + $ [deleteFrom_ #things (#id .== param @1)] +in printSQL definition +:} +CREATE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$; +-} +createProcedure + :: ( Has sch db schema + , KnownSymbol pro + , SOP.SListI args ) + => QualifiedAlias sch pro -- ^ procedure alias + -> NP (TypeExpression db) args -- ^ arguments + -> ProcedureDefinition db args -- ^ procedure definition + -> Definition db (Alter sch (Create pro ('Procedure args) schema) db) +createProcedure pro args prodef = UnsafeDefinition $ + "CREATE" <+> "PROCEDURE" <+> renderSQL pro + <+> parenthesized (renderCommaSeparated renderSQL args) + <+> renderSQL prodef <> ";" + +{- | Create or replace a procedure. +It is not possible to change the name or argument types +of a procedure this way. + +>>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ] +>>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) +>>> :{ +let + definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc]) + definition = createOrReplaceProcedure #proc (one int4) + . languageSqlManipulation + $ [deleteFrom_ #things (#id .== param @1)] +in printSQL definition +:} +CREATE OR REPLACE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$; +-} +createOrReplaceProcedure + :: ( Has sch db schema + , KnownSymbol pro + , SOP.SListI args ) + => QualifiedAlias sch pro -- ^ procedure alias + -> NP (TypeExpression db) args -- ^ arguments + -> ProcedureDefinition db args -- ^ procedure definition + -> Definition db (Alter sch (CreateOrReplace pro ('Procedure args) schema) db) +createOrReplaceProcedure pro args prodef = UnsafeDefinition $ + "CREATE" <+> "OR" <+> "REPLACE" <+> "PROCEDURE" <+> renderSQL pro + <+> parenthesized (renderCommaSeparated renderSQL args) + <+> renderSQL prodef <> ";" + +-- | Use a parameterized `Manipulation` as a procedure body +languageSqlManipulation + :: [Manipulation '[] db args '[]] + -- ^ procedure body + -> ProcedureDefinition db args +languageSqlManipulation mnps = UnsafeProcedureDefinition $ + "language sql as" <+> "$$" <+> Prelude.foldr (<+>) "" (Prelude.map ((<> ";") . renderSQL) mnps) <> "$$" + +-- | + +{- | Drop a procedure. + +>>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4] +>>> :{ +let + definition :: Definition (Public '["proc" ::: Proc]) (Public '[]) + definition = dropProcedure #proc +in printSQL definition +:} +DROP PROCEDURE "proc"; +-} +dropProcedure + :: (Has sch db schema, KnownSymbol pro) + => QualifiedAlias sch pro + -- ^ procedure alias + -> Definition db (Alter sch (DropSchemum pro 'Procedure schema) db) +dropProcedure pro = UnsafeDefinition $ + "DROP PROCEDURE" <+> renderSQL pro <> ";" + +{- | Drop a procedure. + +>>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4 ] +>>> :{ +let + definition :: Definition (Public '[]) (Public '[]) + definition = dropProcedureIfExists #proc +in printSQL definition +:} +DROP PROCEDURE IF EXISTS "proc"; +-} +dropProcedureIfExists + :: (Has sch db schema, KnownSymbol pro) + => QualifiedAlias sch pro + -- ^ procedure alias + -> Definition db (Alter sch (DropSchemumIfExists pro 'Procedure schema) db) +dropProcedureIfExists pro = UnsafeDefinition $ + "DROP PROCEDURE IF EXISTS" <+> renderSQL pro <> ";" + +{- | Body of a user defined procedure-} +newtype ProcedureDefinition db args = UnsafeProcedureDefinition + { renderProcedureDefinition :: ByteString } + deriving (Eq,Show,GHC.Generic,NFData) +instance RenderSQL (ProcedureDefinition db args) where + renderSQL = renderProcedureDefinition diff --git a/src/Squeal/PostgreSQL/Definition/Table.hs b/src/Squeal/PostgreSQL/Definition/Table.hs --- a/src/Squeal/PostgreSQL/Definition/Table.hs +++ b/src/Squeal/PostgreSQL/Definition/Table.hs @@ -41,6 +41,7 @@ , alterTableIfExists , alterTableRename , alterTableIfExistsRename + , alterTableSetSchema , AlterTable (..) -- ** Constraints , addConstraint @@ -235,26 +236,64 @@ -- | `alterTableRename` changes the name of a table from the schema. -- --- >>> printSQL $ alterTableRename #foo #bar +-- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ] +-- >>> :{ +-- let migration :: Definition Schemas '["public" ::: '["bar" ::: 'Table ('[] :=> '[]) ] ] +-- migration = alterTableRename #foo #bar +-- in printSQL migration +-- :} -- ALTER TABLE "foo" RENAME TO "bar"; alterTableRename - :: (KnownSymbol tab0, KnownSymbol tab1) - => Alias tab0 -- ^ table to rename + :: ( Has sch db schema + , KnownSymbol tab1 + , Has tab0 schema ('Table table)) + => QualifiedAlias sch tab0 -- ^ table to rename -> Alias tab1 -- ^ what to rename it - -> Definition schema (Rename tab0 tab1 schema) + -> Definition db (Alter sch (Rename tab0 tab1 schema) db ) alterTableRename tab0 tab1 = UnsafeDefinition $ "ALTER TABLE" <+> renderSQL tab0 <+> "RENAME TO" <+> renderSQL tab1 <> ";" --- | Rename a table if it exists. +-- | `alterTableIfExistsRename` changes the name of a table from the schema if it exists. +-- +-- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ] +-- >>> :{ +-- let migration :: Definition Schemas Schemas +-- migration = alterTableIfExistsRename #goo #gar +-- in printSQL migration +-- :} +-- ALTER TABLE IF EXISTS "goo" RENAME TO "gar"; alterTableIfExistsRename - :: (KnownSymbol tab0, KnownSymbol tab1) - => Alias tab0 -- ^ table to rename + :: ( Has sch db schema + , KnownSymbol tab0 + , KnownSymbol tab1 ) + => QualifiedAlias sch tab0 -- ^ table to rename -> Alias tab1 -- ^ what to rename it - -> Definition schema (RenameIfExists tab0 tab1 schema) + -> Definition db (Alter sch (RenameIfExists tab0 tab1 schema) db ) alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $ "ALTER TABLE IF EXISTS" <+> renderSQL tab0 <+> "RENAME TO" <+> renderSQL tab1 <> ";" + +{- | This form moves the table into another schema. + +>>> type DB0 = '[ "sch0" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ], "sch1" ::: '[] ] +>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ] ] +>>> :{ +let def :: Definition DB0 DB1 + def = alterTableSetSchema (#sch0 ! #tab) #sch1 +in printSQL def +:} +ALTER TABLE "sch0"."tab" SET SCHEMA "sch1"; +-} +alterTableSetSchema + :: ( Has sch0 db schema0 + , Has tab schema0 ('Table table) + , Has sch1 db schema1 ) + => QualifiedAlias sch0 tab -- ^ table to move + -> Alias sch1 -- ^ where to move it + -> Definition db (SetSchema sch0 sch1 schema0 schema1 tab 'Table table db) +alterTableSetSchema tab sch = UnsafeDefinition $ + "ALTER TABLE" <+> renderSQL tab <+> "SET SCHEMA" <+> renderSQL sch <> ";" -- | An `AlterTable` describes the alteration to perform on the columns -- of a table. diff --git a/src/Squeal/PostgreSQL/Definition/Type.hs b/src/Squeal/PostgreSQL/Definition/Type.hs --- a/src/Squeal/PostgreSQL/Definition/Type.hs +++ b/src/Squeal/PostgreSQL/Definition/Type.hs @@ -40,6 +40,9 @@ -- * Drop , dropType , dropTypeIfExists + -- * Alter + , alterTypeRename + , alterTypeSetSchema ) where import Data.ByteString @@ -245,3 +248,44 @@ -> Definition db (Alter sch (DropSchemumIfExists td 'Typedef schema) db) dropTypeIfExists tydef = UnsafeDefinition $ "DROP TYPE IF EXISTS" <+> renderSQL tydef <> ";" + +-- | `alterTypeRename` changes the name of a type from the schema. +-- +-- >>> type DB = '[ "public" ::: '[ "foo" ::: 'Typedef 'PGbool ] ] +-- >>> :{ +-- let def :: Definition DB '["public" ::: '["bar" ::: 'Typedef 'PGbool ] ] +-- def = alterTypeRename #foo #bar +-- in printSQL def +-- :} +-- ALTER TYPE "foo" RENAME TO "bar"; +alterTypeRename + :: ( Has sch db schema + , KnownSymbol ty1 + , Has ty0 schema ('Typedef ty)) + => QualifiedAlias sch ty0 -- ^ type to rename + -> Alias ty1 -- ^ what to rename it + -> Definition db (Alter sch (Rename ty0 ty1 schema) db ) +alterTypeRename ty0 ty1 = UnsafeDefinition $ + "ALTER TYPE" <+> renderSQL ty0 + <+> "RENAME TO" <+> renderSQL ty1 <> ";" + +{- | This form moves the type into another schema. + +>>> type DB0 = '[ "sch0" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ], "sch1" ::: '[] ] +>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ] ] +>>> :{ +let def :: Definition DB0 DB1 + def = alterTypeSetSchema (#sch0 ! #ty) #sch1 +in printSQL def +:} +ALTER TYPE "sch0"."ty" SET SCHEMA "sch1"; +-} +alterTypeSetSchema + :: ( Has sch0 db schema0 + , Has ty schema0 ('Typedef td) + , Has sch1 db schema1 ) + => QualifiedAlias sch0 ty -- ^ type to move + -> Alias sch1 -- ^ where to move it + -> Definition db (SetSchema sch0 sch1 schema0 schema1 ty 'Typedef td db) +alterTypeSetSchema ty sch = UnsafeDefinition $ + "ALTER TYPE" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";" diff --git a/src/Squeal/PostgreSQL/Definition/View.hs b/src/Squeal/PostgreSQL/Definition/View.hs --- a/src/Squeal/PostgreSQL/Definition/View.hs +++ b/src/Squeal/PostgreSQL/Definition/View.hs @@ -36,6 +36,9 @@ -- * Drop , dropView , dropViewIfExists + -- * Alter + , alterViewRename + , alterViewSetSchema ) where import GHC.TypeLits @@ -133,3 +136,44 @@ -> Definition db (Alter sch (DropIfExists vw schema) db) dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";" + +-- | `alterViewRename` changes the name of a view from the schema. +-- +-- >>> type DB = '[ "public" ::: '[ "foo" ::: 'View '[] ] ] +-- >>> :{ +-- let def :: Definition DB '["public" ::: '["bar" ::: 'View '[] ] ] +-- def = alterViewRename #foo #bar +-- in printSQL def +-- :} +-- ALTER VIEW "foo" RENAME TO "bar"; +alterViewRename + :: ( Has sch db schema + , KnownSymbol ty1 + , Has ty0 schema ('View vw)) + => QualifiedAlias sch ty0 -- ^ view to rename + -> Alias ty1 -- ^ what to rename it + -> Definition db (Alter sch (Rename ty0 ty1 schema) db ) +alterViewRename vw0 vw1 = UnsafeDefinition $ + "ALTER VIEW" <+> renderSQL vw0 + <+> "RENAME TO" <+> renderSQL vw1 <> ";" + +{- | This form moves the view into another schema. + +>>> type DB0 = '[ "sch0" ::: '[ "vw" ::: 'View '[] ], "sch1" ::: '[] ] +>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "vw" ::: 'View '[] ] ] +>>> :{ +let def :: Definition DB0 DB1 + def = alterViewSetSchema (#sch0 ! #vw) #sch1 +in printSQL def +:} +ALTER VIEW "sch0"."vw" SET SCHEMA "sch1"; +-} +alterViewSetSchema + :: ( Has sch0 db schema0 + , Has vw schema0 ('View view) + , Has sch1 db schema1 ) + => QualifiedAlias sch0 vw -- ^ view to move + -> Alias sch1 -- ^ where to move it + -> Definition db (SetSchema sch0 sch1 schema0 schema1 vw 'View view db) +alterViewSetSchema ty sch = UnsafeDefinition $ + "ALTER VIEW" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";" diff --git a/src/Squeal/PostgreSQL/Expression.hs b/src/Squeal/PostgreSQL/Expression.hs --- a/src/Squeal/PostgreSQL/Expression.hs +++ b/src/Squeal/PostgreSQL/Expression.hs @@ -141,14 +141,7 @@ -- ^ cannot reference aliases -- | A @RankNType@ for binary operators. -type Operator x1 x2 y - = forall grp lat with db params from - . Expression grp lat with db params from x1 - -- ^ left input - -> Expression grp lat with db params from x2 - -- ^ right input - -> Expression grp lat with db params from y - -- ^ output +type Operator x1 x2 y = forall db. OperatorDB db x1 x2 y -- | Like `Operator` but depends on the schemas of the database type OperatorDB db x1 x2 y @@ -210,46 +203,46 @@ unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x) -instance (HasUnique tab (Join lat from) row, Has col row ty) +instance (HasUnique tab (Join from lat) row, Has col row ty) => IsLabel col (Expression 'Ungrouped lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col) -instance (HasUnique tab (Join lat from) row, Has col row ty, tys ~ '[ty]) +instance (HasUnique tab (Join from lat) row, Has col row ty, tys ~ '[ty]) => IsLabel col (NP (Expression 'Ungrouped lat with db params from) tys) where fromLabel = fromLabel @col :* Nil -instance (HasUnique tab (Join lat from) row, Has col row ty, column ~ (col ::: ty)) +instance (HasUnique tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) => IsLabel col (Aliased (Expression 'Ungrouped lat with db params from) column) where fromLabel = fromLabel @col `As` Alias -instance (HasUnique tab (Join lat from) row, Has col row ty, columns ~ '[col ::: ty]) +instance (HasUnique tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) => IsLabel col (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where fromLabel = fromLabel @col :* Nil -instance (Has tab (Join lat from) row, Has col row ty) +instance (Has tab (Join from lat) row, Has col row ty) => IsQualified tab col (Expression 'Ungrouped lat with db params from ty) where tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col -instance (Has tab (Join lat from) row, Has col row ty, tys ~ '[ty]) +instance (Has tab (Join from lat) row, Has col row ty, tys ~ '[ty]) => IsQualified tab col (NP (Expression 'Ungrouped lat with db params from) tys) where tab ! col = tab ! col :* Nil -instance (Has tab (Join lat from) row, Has col row ty, column ~ (col ::: ty)) +instance (Has tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) => IsQualified tab col (Aliased (Expression 'Ungrouped lat with db params from) column) where tab ! col = tab ! col `As` col -instance (Has tab (Join lat from) row, Has col row ty, columns ~ '[col ::: ty]) +instance (Has tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) => IsQualified tab col (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where tab ! col = tab ! col :* Nil instance - ( HasUnique tab (Join lat from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsLabel col (Expression ('Grouped bys) lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col) instance - ( HasUnique tab (Join lat from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty] @@ -257,7 +250,7 @@ (NP (Expression ('Grouped bys) lat with db params from) tys) where fromLabel = fromLabel @col :* Nil instance - ( HasUnique tab (Join lat from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty) @@ -265,7 +258,7 @@ (Aliased (Expression ('Grouped bys) lat with db params from) column) where fromLabel = fromLabel @col `As` Alias instance - ( HasUnique tab (Join lat from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty] @@ -274,7 +267,7 @@ fromLabel = fromLabel @col :* Nil instance - ( Has tab (Join lat from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsQualified tab col @@ -282,7 +275,7 @@ tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col instance - ( Has tab (Join lat from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty] @@ -290,7 +283,7 @@ (NP (Expression ('Grouped bys) lat with db params from) tys) where tab ! col = tab ! col :* Nil instance - ( Has tab (Join lat from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty) @@ -298,7 +291,7 @@ (Aliased (Expression ('Grouped bys) lat with db params from) column) where tab ! col = tab ! col `As` col instance - ( Has tab (Join lat from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty] diff --git a/src/Squeal/PostgreSQL/Expression/Aggregate.hs b/src/Squeal/PostgreSQL/Expression/Aggregate.hs --- a/src/Squeal/PostgreSQL/Expression/Aggregate.hs +++ b/src/Squeal/PostgreSQL/Expression/Aggregate.hs @@ -28,6 +28,7 @@ module Squeal.PostgreSQL.Expression.Aggregate ( -- * Aggregate Aggregate (..) + -- * Aggregate Arguments , AggregateArg (..) , pattern All , pattern Alls @@ -416,11 +417,17 @@ = AggregateAll { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from] - , aggregateFilter :: [Condition 'Ungrouped lat with db params from] } + -- ^ `orderBy` + , aggregateFilter :: [Condition 'Ungrouped lat with db params from] + -- ^ `filterWhere` + } | AggregateDistinct { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from] - , aggregateFilter :: [Condition 'Ungrouped lat with db params from] } + -- ^ `orderBy` + , aggregateFilter :: [Condition 'Ungrouped lat with db params from] + -- ^ `filterWhere` + } instance SOP.SListI xs => RenderSQL (AggregateArg xs lat with db params from) where renderSQL = \case @@ -447,6 +454,7 @@ -- argument once for each input row. pattern All :: Expression 'Ungrouped lat with db params from x + -- ^ argument -> AggregateArg '[x] lat with db params from pattern All x = Alls (x :* Nil) @@ -454,6 +462,7 @@ -- arguments once for each input row. pattern Alls :: NP (Expression 'Ungrouped lat with db params from) xs + -- ^ arguments -> AggregateArg xs lat with db params from pattern Alls xs = AggregateAll xs [] [] @@ -462,6 +471,7 @@ -- is not null allNotNull :: Expression 'Ungrouped lat with db params from ('Null x) + -- ^ argument -> AggregateArg '[ 'NotNull x] lat with db params from allNotNull x = All (unsafeNotNull x) & filterWhere (not_ (isNull x)) @@ -471,6 +481,7 @@ -} pattern Distinct :: Expression 'Ungrouped lat with db params from x + -- ^ argument -> AggregateArg '[x] lat with db params from pattern Distinct x = Distincts (x :* Nil) @@ -480,6 +491,7 @@ -} pattern Distincts :: NP (Expression 'Ungrouped lat with db params from) xs + -- ^ arguments -> AggregateArg xs lat with db params from pattern Distincts xs = AggregateDistinct xs [] [] @@ -489,6 +501,7 @@ -} distinctNotNull :: Expression 'Ungrouped lat with db params from ('Null x) + -- ^ argument -> AggregateArg '[ 'NotNull x] lat with db params from distinctNotNull x = Distinct (unsafeNotNull x) & filterWhere (not_ (isNull x)) @@ -502,6 +515,7 @@ -} filterWhere :: Condition grp lat with db params from + -- ^ include rows which evaluate to true -> arg xs lat with db params from -> arg xs lat with db params from instance FilterWhere AggregateArg 'Ungrouped where diff --git a/src/Squeal/PostgreSQL/Expression/Array.hs b/src/Squeal/PostgreSQL/Expression/Array.hs --- a/src/Squeal/PostgreSQL/Expression/Array.hs +++ b/src/Squeal/PostgreSQL/Expression/Array.hs @@ -32,15 +32,21 @@ , array2 , cardinality , index + , index1 + , index2 , unnest + , arrAny + , arrAll ) where import Data.String import Data.Word (Word64) +import GHC.TypeNats import qualified Generics.SOP as SOP import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Expression.Type import Squeal.PostgreSQL.Query.From.Set import Squeal.PostgreSQL.Render @@ -133,12 +139,104 @@ index :: Word64 -- ^ index -> null ('PGvararray ty) --> NullifyType ty -index n expr = UnsafeExpression $ - parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]" +index i arr = UnsafeExpression $ + parenthesized (renderSQL arr) <> "[" <> fromString (show i) <> "]" +-- | Typesafe indexing of fixed length arrays. +-- +-- >>> printSQL $ array1 (true *: false) & index1 @1 +-- (ARRAY[TRUE, FALSE])[1] +index1 + :: forall i n ty + . (1 <= i, i <= n, KnownNat i) + => 'NotNull ('PGfixarray '[n] ty) --> ty + -- ^ vector index +index1 arr = UnsafeExpression $ + parenthesized (renderSQL arr) + <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]" + +-- | Typesafe indexing of fixed size matrices. +-- +-- >>> printSQL $ array2 ((true *: false) *: (false *: true)) & index2 @1 @2 +-- (ARRAY[[TRUE, FALSE], [FALSE, TRUE]])[1][2] +index2 + :: forall i j m n ty + . ( 1 <= i, i <= m, KnownNat i + , 1 <= j, j <= n, KnownNat j + ) + => 'NotNull ('PGfixarray '[m,n] ty) --> ty + -- ^ matrix index +index2 arr = UnsafeExpression $ + parenthesized (renderSQL arr) + <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]" + <> "[" <> fromString (show (natVal (SOP.Proxy @j))) <> "]" + -- | Expand an array to a set of rows -- -- >>> printSQL $ unnest (array [null_, false, true]) -- unnest(ARRAY[NULL, FALSE, TRUE]) unnest :: null ('PGvararray ty) -|-> ("unnest" ::: '["unnest" ::: ty]) unnest = unsafeSetFunction "unnest" + +{- | +The right-hand side is a parenthesized expression, +which must yield an array value. The left-hand expression +is evaluated and compared to each element of the array using +the given `Operator`, which must yield a Boolean result. +The result of `arrAll` is `true` if all comparisons yield true +(including the case where the array has zero elements). +The result is `false` if any false result is found. + +If the array expression yields a null array, +the result of `arrAll` will be null. If the left-hand expression yields null, +the result of `arrAll` is ordinarily null +(though a non-strict comparison `Operator` +could possibly yield a different result). +Also, if the right-hand array contains any null +elements and no false comparison result is obtained, +the result of `arrAll` will be null, not true +(again, assuming a strict comparison `Operator`). +This is in accordance with SQL's normal rules for Boolean +combinations of null values. + +>>> printSQL $ arrAll true (.==) (array [true, false, null_]) +(TRUE = ALL (ARRAY[TRUE, FALSE, NULL])) +>>> printSQL $ arrAll "hi" like (array ["bi","hi"]) +((E'hi' :: text) LIKE ALL (ARRAY[(E'bi' :: text), (E'hi' :: text)])) +-} +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 + -> Condition grp lat with db params from +arrAll x (?) xs = x ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL xs)) + +{- | +The right-hand side is a parenthesized expression, which must yield an array +value. The left-hand expression is evaluated and compared to each element of +the array using the given `Operator`, which must yield a Boolean result. The +result of `arrAny` is `true` if any true result is obtained. The result is +`false` if no true result is found (including the case where the array +has zero elements). + +If the array expression yields a null array, the result of `arrAny` will +be null. If the left-hand expression yields null, the result of `arrAny` is +ordinarily null (though a non-strict comparison `Operator` could possibly +yield a different result). Also, if the right-hand array contains any +null elements and no true comparison result is obtained, the result of +`arrAny` will be null, not false +(again, assuming a strict comparison `Operator`). +This is in accordance with SQL's normal rules for +Boolean combinations of null values. + +>>> printSQL $ arrAny true (.==) (array [true, false, null_]) +(TRUE = ANY (ARRAY[TRUE, FALSE, NULL])) +>>> printSQL $ arrAny "hi" like (array ["bi","hi"]) +((E'hi' :: text) LIKE ANY (ARRAY[(E'bi' :: text), (E'hi' :: text)])) +-} +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 + -> Condition grp lat with db params from +arrAny x (?) xs = x ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL xs)) diff --git a/src/Squeal/PostgreSQL/Expression/Comparison.hs b/src/Squeal/PostgreSQL/Expression/Comparison.hs --- a/src/Squeal/PostgreSQL/Expression/Comparison.hs +++ b/src/Squeal/PostgreSQL/Expression/Comparison.hs @@ -92,7 +92,7 @@ (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> let expr = greatest [param @1] currentTimestamp :: Expression grp lat with db '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz) +-- | >>> let expr = greatest [param @1] currentTimestamp -- >>> printSQL expr -- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP) greatest :: FunctionVar ty ty ty diff --git a/src/Squeal/PostgreSQL/Expression/Inline.hs b/src/Squeal/PostgreSQL/Expression/Inline.hs --- a/src/Squeal/PostgreSQL/Expression/Inline.hs +++ b/src/Squeal/PostgreSQL/Expression/Inline.hs @@ -45,9 +45,9 @@ import Data.String import Data.Text (Text) import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, UTCTime) -import Data.Time.Format (formatTime, defaultTimeLocale) -import Data.Time.Calendar (Day, toGregorian) -import Data.Time.LocalTime (LocalTime(LocalTime), TimeOfDay(TimeOfDay), TimeZone) +import Data.Time.Format.ISO8601 (formatShow, timeOfDayAndOffsetFormat, FormatExtension(ExtendedFormat), iso8601Show) +import Data.Time.Calendar (Day) +import Data.Time.LocalTime (LocalTime, TimeOfDay, TimeZone) import Data.UUID.Types (UUID, toASCIIBytes) import Data.Vector (Vector, toList) import Database.PostgreSQL.LibPQ (Oid(Oid)) @@ -179,35 +179,40 @@ interval_ (fromIntegral secs) Seconds +! interval_ (fromIntegral microsecs) Microseconds instance Inline Day where - inline day = - let (y,m,d) = toGregorian day - in inferredtype $ makeDate (fromInteger y :* fromIntegral m *: fromIntegral d) + inline + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show instance Inline UTCTime where inline = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString - . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q%z" + . iso8601Show instance Inline (TimeOfDay, TimeZone) where - inline (hms, tz) + inline = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString - $ formatTime defaultTimeLocale "%H:%M:%S" hms - <> formatTime defaultTimeLocale "%z" tz + . formatShow (timeOfDayAndOffsetFormat ExtendedFormat) instance Inline TimeOfDay where - inline (TimeOfDay hr mn sc) = inferredtype $ makeTime - (fromIntegral hr :* fromIntegral mn *: fromRational (toRational sc)) + inline + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show instance Inline LocalTime where - inline (LocalTime day t) = - let - (y,m,d) = toGregorian day - TimeOfDay hr mn sc = t - in inferredtype $ makeTimestamp - ( fromInteger y :* fromIntegral m :* fromIntegral d - :* fromIntegral hr :* fromIntegral mn *: fromRational (toRational sc) ) + inline + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show instance Inline (Range Int32) where inline = range int4range . fmap inline instance Inline (Range Int64) where @@ -290,7 +295,7 @@ => InlineField (alias ::: x) (alias ::: ty) where inlineField (SOP.P x) = inlineParam x `as` Alias @alias --- | Use a Haskell record as a inline a row of expressions. +-- | Inline a Haskell record as a row of expressions. inlineFields :: ( SOP.IsRecord hask fields , SOP.AllZip InlineField fields row ) @@ -320,7 +325,7 @@ Default -> Default `as` (Alias @col) Set (SOP.I x) -> Set (inlineParam x) `as` (Alias @col) --- | Use a Haskell record as a inline list of columns +-- | Inline a Haskell record as a list of columns. inlineColumns :: ( SOP.IsRecord hask xs , SOP.AllZip InlineColumn xs columns ) diff --git a/src/Squeal/PostgreSQL/Expression/Null.hs b/src/Squeal/PostgreSQL/Expression/Null.hs --- a/src/Squeal/PostgreSQL/Expression/Null.hs +++ b/src/Squeal/PostgreSQL/Expression/Null.hs @@ -63,6 +63,7 @@ -- nullity as `NotNull`. monoNotNull :: (forall null. Expression grp lat with db params from (null ty)) + -- ^ null polymorphic -> Expression grp lat with db params from ('NotNull ty) monoNotNull = id @@ -114,9 +115,8 @@ {-| right inverse to `fromNull`, if its arguments are equal then `nullIf` gives @NULL@. ->>> :set -XTypeApplications -XDataKinds ->>> let expr = nullIf (false *: param @1) :: Expression grp lat with db '[ 'NotNull 'PGbool] from ('Null 'PGbool) ->>> printSQL expr +>>> :set -XTypeApplications +>>> printSQL (nullIf (false *: param @1)) NULLIF(FALSE, ($1 :: bool)) -} nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty diff --git a/src/Squeal/PostgreSQL/Expression/Parameter.hs b/src/Squeal/PostgreSQL/Expression/Parameter.hs --- a/src/Squeal/PostgreSQL/Expression/Parameter.hs +++ b/src/Squeal/PostgreSQL/Expression/Parameter.hs @@ -14,6 +14,7 @@ , FlexibleContexts , FlexibleInstances , FunctionalDependencies + , GADTs , KindSignatures , MultiParamTypeClasses , OverloadedStrings @@ -55,8 +56,7 @@ | n params -> ty where -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. -- - -- >>> let expr = parameter @1 int4 :: Expression lat '[] grp db '[ 'Null 'PGint4] from ('Null 'PGint4) - -- >>> printSQL expr + -- >>> printSQL (parameter @1 int4) -- ($1 :: int4) parameter :: TypeExpression db ty @@ -64,15 +64,15 @@ parameter ty = UnsafeExpression $ parenthesized $ "$" <> renderNat @n <+> "::" <+> renderSQL ty -instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1 -instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty) - => HasParameter n (ty' : params) 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 -- | `param` takes a `Nat` using type application and for basic types, -- infers a `TypeExpression`. -- --- >>> let expr = param @1 :: Expression grp lat with db '[ 'Null 'PGint4] from ('Null 'PGint4) --- >>> printSQL expr +-- >>> printSQL (param @1 @('Null 'PGint4)) -- ($1 :: int4) param :: forall n ty lat with db params from grp diff --git a/src/Squeal/PostgreSQL/Expression/Range.hs b/src/Squeal/PostgreSQL/Expression/Range.hs --- a/src/Squeal/PostgreSQL/Expression/Range.hs +++ b/src/Squeal/PostgreSQL/Expression/Range.hs @@ -152,7 +152,7 @@ -- | contains range (@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool) -(@>.) = unsafeBinaryOp "<@" +(@>.) = unsafeBinaryOp "@>" -- | strictly left of, -- return false when an empty range is involved diff --git a/src/Squeal/PostgreSQL/Expression/Type.hs b/src/Squeal/PostgreSQL/Expression/Type.hs --- a/src/Squeal/PostgreSQL/Expression/Type.hs +++ b/src/Squeal/PostgreSQL/Expression/Type.hs @@ -359,6 +359,7 @@ instance PGTyped db 'PGtimetz where pgtype = timeWithTimeZone instance PGTyped db 'PGinterval where pgtype = interval instance PGTyped db 'PGuuid where pgtype = uuid +instance PGTyped db 'PGinet where pgtype = inet instance PGTyped db 'PGjson where pgtype = json instance PGTyped db 'PGjsonb where pgtype = jsonb instance PGTyped db pg => PGTyped db ('PGvararray (null pg)) where diff --git a/src/Squeal/PostgreSQL/Expression/Window.hs b/src/Squeal/PostgreSQL/Expression/Window.hs --- a/src/Squeal/PostgreSQL/Expression/Window.hs +++ b/src/Squeal/PostgreSQL/Expression/Window.hs @@ -118,7 +118,7 @@ orderBy sortsR (WindowDefinition parts sortsL) = WindowDefinition parts (sortsL ++ sortsR) -instance RenderSQL (WindowDefinition lat with db from grp params) where +instance RenderSQL (WindowDefinition grp lat with db params from) where renderSQL (WindowDefinition part ord) = renderPartitionByClause part <> renderSQL ord where @@ -173,7 +173,9 @@ (from :: FromType) = WindowArg { windowArgs :: NP (Expression grp lat with db params from) args + -- ^ `Window` or `Windows` , windowFilter :: [Condition grp lat with db params from] + -- ^ `filterWhere` } deriving stock (GHC.Generic) instance SOP.SListI args @@ -193,12 +195,14 @@ -- | `Window` invokes a `WindowFunction` on a single argument. pattern Window :: Expression grp lat with db params from arg + -- ^ argument -> WindowArg grp '[arg] lat with db params from pattern Window x = Windows (x :* Nil) -- | `Windows` invokes a `WindowFunction` on multiple argument. pattern Windows :: NP (Expression grp lat with db params from) args + -- ^ arguments -> WindowArg grp args lat with db params from pattern Windows xs = WindowArg xs [] diff --git a/src/Squeal/PostgreSQL/Manipulation.hs b/src/Squeal/PostgreSQL/Manipulation.hs --- a/src/Squeal/PostgreSQL/Manipulation.hs +++ b/src/Squeal/PostgreSQL/Manipulation.hs @@ -31,11 +31,12 @@ module Squeal.PostgreSQL.Manipulation ( -- * Manipulation - Manipulation_ - , Manipulation (..) + Manipulation (..) + , Manipulation_ , queryStatement , ReturningClause (..) , pattern Returning_ + , UsingClause (..) ) where import Control.DeepSeq @@ -52,6 +53,7 @@ import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Query.From import Squeal.PostgreSQL.Query.Select import Squeal.PostgreSQL.Query.With import Squeal.PostgreSQL.Type.Schema @@ -63,58 +65,20 @@ {- | A `Manipulation` is a statement which may modify data in the database, -but does not alter its schemas. Examples are inserts, updates and deletes. -A `Query` is also considered a `Manipulation` even though it does not modify data. +but does not alter its schemas. Examples are +`Squeal.PostgreSQL.Manipulation.Insert.insertInto`s, +`Squeal.PostgreSQL.Manipulation.Update.update`s and +`Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`s. +A `queryStatement` is also considered a `Manipulation` even though it does not modify data. The general `Manipulation` type is parameterized by * @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions, * @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s, * @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, -* @row :: RowType@ - return type of the `Query`. --} -newtype Manipulation - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (columns :: RowType) - = UnsafeManipulation { renderManipulation :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (Manipulation with db params columns) where - renderSQL = renderManipulation -instance With Manipulation where - with Done manip = manip - with ctes manip = UnsafeManipulation $ - "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL manip - -{- | -The top level `Manipulation_` type is parameterized by a @db@ `SchemasType`, -against which the query is type-checked, an input @params@ Haskell `Type`, -and an ouput row Haskell `Type`. - -`Manipulation_` is a type family which resolves into a `Manipulation`, -so don't be fooled by the input params and output row Haskell `Type`s, -which are converted into appropriate -Postgres @[@`NullType`@]@ params and `RowType` rows. -Use a top-level `Squeal.PostgreSQL.Session.Statement.Statement` to -fix actual Haskell input params and output rows. - -A top-level `Manipulation_` can be run -using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@ -using `Squeal.PostgreSQL.Session.manipulate`. - -Generally, @params@ will be a Haskell tuple or record whose entries -may be referenced using positional -`Squeal.PostgreSQL.Expression.Parameter.param`s and @row@ will be a -Haskell record, whose entries will be targeted using overloaded labels. +* @row :: RowType@ - return type of the `Manipulation`. ->>> :set -XDeriveAnyClass -XDerivingStrategies ->>> :{ -data Row a b = Row { col1 :: a, col2 :: b } - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} +Let's see some examples of `Manipulation`s. simple insert: @@ -122,12 +86,12 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let - manipulation :: Manipulation_ (Public Schema) () () - manipulation = + manp :: Manipulation with (Public Schema) '[] '[] + manp = insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) -in printSQL manipulation +in printSQL manp :} -INSERT INTO "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) out-of-line parameterized insert: @@ -135,41 +99,45 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let - manipulation :: Manipulation_ (Public Schema) (Only Int32) () - manipulation = + manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[] + manp = insertInto_ #tab $ Values_ (Default `as` #col1 :* Set (param @1) `as` #col2) -in printSQL manipulation +in printSQL manp :} -INSERT INTO "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4)) +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4)) in-line parameterized insert: >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ +data Row = Row { col1 :: Optional SOP.I ('Def :=> Int32), col2 :: Int32 } + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +:} + +>>> :{ let - manipulation - :: Manipulation_ (Public Schema) () () - manipulation = - insertInto_ #tab $ inlineValues - (Row {col1 = Default , col2 = 2 :: Int32}) - [Row {col1 = NotDefault (3 :: Int32), col2 = 4 :: Int32}] -in printSQL manipulation + manp :: Row -> Row -> Manipulation with (Public Schema) '[] '[] + manp row1 row2 = insertInto_ #tab $ inlineValues row1 [row2] + row1 = Row {col1 = Default, col2 = 2 :: Int32} + row2 = Row {col1 = NotDefault (3 :: Int32), col2 = 4 :: Int32} +in printSQL (manp row1 row2) :} -INSERT INTO "tab" ("col1", "col2") VALUES (DEFAULT, (2 :: int4)), ((3 :: int4), (4 :: int4)) +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, (2 :: int4)), ((3 :: int4), (4 :: int4)) returning insert: >>> :{ let - manipulation :: Manipulation_ (Public Schema) () (Only Int32) - manipulation = + manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4] + manp = insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2)) - OnConflictDoRaise (Returning (#col1 `as` #fromOnly)) -in printSQL manipulation + OnConflictDoRaise (Returning #col1) +in printSQL manp :} -INSERT INTO "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "fromOnly" +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "col1" upsert: @@ -178,46 +146,46 @@ >>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] >>> :{ let - manipulation :: Manipulation_ (Public CustomersSchema) () () - manipulation = + manp :: Manipulation with (Public CustomersSchema) '[] '[] + manp = insertInto #customers (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email)) (OnConflict (OnConstraint #uq) (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) [])) (Returning_ Nil) -in printSQL manipulation +in printSQL manp :} -INSERT INTO "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) +INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) query insert: >>> :{ let - manipulation :: Manipulation_ (Public Schema) () () - manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab)))) -in printSQL manipulation + manp :: Manipulation with (Public Schema) '[] '[] + manp = insertInto_ #tab (Subquery (select Star (from (table #tab)))) +in printSQL manp :} -INSERT INTO "tab" SELECT * FROM "tab" AS "tab" +INSERT INTO "tab" AS "tab" SELECT * FROM "tab" AS "tab" update: >>> :{ let - manipulation :: Manipulation_ (Public Schema) () () - manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) -in printSQL manipulation + manp :: Manipulation with (Public Schema) '[] '[] + manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) +in printSQL manp :} -UPDATE "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") +UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") delete: >>> :{ let - manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32) - manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star) -in printSQL manipulation + manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + manp = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star) +in printSQL manp :} -DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING * +DELETE FROM "tab" AS "tab" WHERE ("col1" = "col2") RETURNING * delete and using clause: @@ -230,15 +198,15 @@ >>> :{ let - manipulation :: Manipulation_ (Public Schema3) () () - manipulation = + manp :: Manipulation with (Public Schema3) '[] '[] + manp = deleteFrom #tab (Using (table #other_tab & also (table #third_tab))) ( (#tab ! #col2 .== #other_tab ! #col2) .&& (#tab ! #col2 .== #third_tab ! #col2) ) (Returning_ Nil) -in printSQL manipulation +in printSQL manp :} -DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2")) +DELETE FROM "tab" AS "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2")) with manipulation: @@ -246,14 +214,81 @@ >>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)] >>> :{ let - manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) () - manipulation = with + manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[] + manp = with (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del) (insertInto_ #products_deleted (Subquery (select Star (from (common #del))))) -in printSQL manipulation +in printSQL manp :} -WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del" +WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del" -} +newtype Manipulation + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (columns :: RowType) + = UnsafeManipulation { renderManipulation :: ByteString } + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (Manipulation with db params columns) where + renderSQL = renderManipulation +instance With Manipulation where + with Done manip = manip + with ctes manip = UnsafeManipulation $ + "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL manip + +{- | +The `Manipulation_` type is parameterized by a @db@ `SchemasType`, +against which it is type-checked, an input @params@ Haskell `Type`, +and an ouput row Haskell `Type`. + +Generally, @params@ will be a Haskell tuple or record whose entries +may be referenced using positional +`Squeal.PostgreSQL.Expression.Parameter.param`s and @row@ will be a +Haskell record, whose entries will be targeted using overloaded labels. + +A `Manipulation_` can be run +using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@ +using `Squeal.PostgreSQL.Session.manipulate`. + +`Manipulation_` is a type family which resolves into a `Manipulation`, +so don't be fooled by the input params and output row Haskell `Type`s, +which are converted into appropriate +Postgres @[@`NullType`@]@ params and `RowType` rows. +Use `Squeal.PostgreSQL.Session.Statement.manipulation` to +fix actual Haskell input params and output rows. + +>>> :set -XDeriveAnyClass -XDerivingStrategies +>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +data Row = Row { col1 :: Maybe Int64, col2 :: String } + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +:} + +>>> :{ +let + manp :: Manipulation_ (Public Schema) (Int64, Int64) Row + manp = deleteFrom #tab NoUsing (#col1 .== param @1 + param @2) (Returning Star) + stmt :: Statement (Public Schema) (Int64, Int64) Row + stmt = manipulation manp +:} + +>>> :type manp +manp + :: Manipulation + '[] + '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] + '[ 'NotNull 'PGint8, 'NotNull 'PGint8] + '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext] +>>> :type stmt +stmt + :: Statement + '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] + (Int64, Int64) + Row +-} type family Manipulation_ (db :: SchemasType) (params :: Type) (row :: Type) where Manipulation_ db params row = Manipulation '[] db (TuplePG params) (RowPG row) @@ -264,7 +299,7 @@ -> Manipulation with db params columns queryStatement q = UnsafeManipulation $ renderSQL q --- | A `ReturningClause` computes and return value(s) based +-- | A `ReturningClause` computes and returns value(s) based -- on each row actually inserted, updated or deleted. This is primarily -- useful for obtaining values that were supplied by defaults, such as a -- serial sequence number. However, any expression using the table's columns @@ -273,7 +308,7 @@ -- but not updated because an `Squeal.PostgreSQL.Manipulation.Insert.OnConflict` -- `Squeal.PostgreSQL.Manipulation.Insert.DoUpdate` condition was not satisfied, -- the row will not be returned. `Returning` `Star` will return all columns --- in the row. Use `Returning` `Nil` in the common case where no return +-- in the row. Use `Returning_` `Nil` in the common case where no return -- values are desired. newtype ReturningClause with db params from row = Returning (Selection 'Ungrouped '[] with db params from row) @@ -290,3 +325,19 @@ -- ^ row of values -> ReturningClause with db params from row pattern Returning_ list = Returning (List list) + +-- | Specify additional tables with `Using` +-- an `also` list of table expressions, allowing columns +-- from other tables to appear in the WHERE condition. +-- This is similar to the list of tables that can be specified +-- in the FROM Clause of a SELECT statement; +-- for example, an alias for the table name can be specified. +-- Do not repeat the target table in the `Using` list, +-- unless you wish to set up a self-join. +-- `NoUsing` if no additional tables are to be used. +data UsingClause with db params from where + NoUsing :: UsingClause with db params '[] + Using + :: FromClause '[] with db params from + -- ^ what to use + -> UsingClause with db params from diff --git a/src/Squeal/PostgreSQL/Manipulation/Call.hs b/src/Squeal/PostgreSQL/Manipulation/Call.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Manipulation/Call.hs @@ -0,0 +1,117 @@ +{-| +Module: Squeal.PostgreSQL.Call +Description: call statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +call statements +-} + +{-# LANGUAGE + DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PatternSynonyms + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeInType + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Manipulation.Call + ( -- * Call + call + , unsafeCall + , callN + , unsafeCallN + ) where + +import Data.ByteString hiding (foldr) + +import Generics.SOP (SListI) + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | +>>> printSQL $ unsafeCall "p" true +CALL p(TRUE) +-} +unsafeCall + :: ByteString -- ^ procedure to call + -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments + -> Manipulation with db params '[] +unsafeCall pro x = UnsafeManipulation $ + "CALL" <+> pro <> parenthesized (renderSQL x) + +{- | Call a user defined procedure of one variable. + +>>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4 ] ] +>>> :{ +let + p :: Manipulation '[] (Public Schema) '[] '[] + p = call #p 1 +in + printSQL p +:} +CALL "p"((1 :: int4)) +-} +call + :: ( Has sch db schema + , Has pro schema ('Procedure '[x]) ) + => QualifiedAlias sch pro -- ^ procedure to call + -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments + -> Manipulation with db params '[] +call = unsafeCall . renderSQL + + +{- | +>>> printSQL $ unsafeCallN "p" (true *: false) +CALL p(TRUE, FALSE) +-} +unsafeCallN + :: SListI xs + => ByteString -- ^ procedure to call + -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments + -> Manipulation with db params '[] +unsafeCallN pro xs = UnsafeManipulation $ + "CALL" <+> pro <> parenthesized (renderCommaSeparated renderSQL xs) + +{- | Call a user defined procedure. + +>>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] ] +>>> :{ +let + p :: Manipulation '[] (Public Schema) '[] '[] + p = callN #p (1 *: "hi") +in + printSQL p +:} +CALL "p"((1 :: int4), (E'hi' :: text)) +-} +callN + :: ( Has sch db schema + , Has pro schema ('Procedure xs) + , SListI xs ) + => QualifiedAlias sch pro -- ^ procedure to call + -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments + -> Manipulation with db params '[] +callN = unsafeCallN . renderSQL diff --git a/src/Squeal/PostgreSQL/Manipulation/Delete.hs b/src/Squeal/PostgreSQL/Manipulation/Delete.hs --- a/src/Squeal/PostgreSQL/Manipulation/Delete.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Delete.hs @@ -33,7 +33,6 @@ ( -- * Delete deleteFrom , deleteFrom_ - , UsingClause (..) ) where import qualified Generics.SOP as SOP @@ -43,7 +42,6 @@ import Squeal.PostgreSQL.Manipulation import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Query.From import Squeal.PostgreSQL.Type.Schema -- $setup @@ -53,48 +51,54 @@ DELETE statements -----------------------------------------} --- | Specify additional tables with `Using` --- an `also` list of table expressions, allowing columns --- from other tables to appear in the WHERE condition. --- This is similar to the list of tables that can be specified --- in the FROM Clause of a SELECT statement; --- for example, an alias for the table name can be specified. --- Do not repeat the target table in the `Using` list, --- unless you wish to set up a self-join. --- `NoUsing` if no additional tables are to be used. -data UsingClause with db params from where - NoUsing :: UsingClause with db params '[] - Using - :: FromClause '[] with db params from - -- ^ what to use - -> UsingClause with db params from +{- | Delete rows from a table. --- | Delete rows from a table. +>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] +>>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + manp = deleteFrom #tab1 (Using (table #tab2)) (#tab1 ! #col1 .== #tab2 ! #col2) (Returning (#tab1 & DotStar)) +in printSQL manp +:} +DELETE FROM "tab1" AS "tab1" USING "tab2" AS "tab2" WHERE ("tab1"."col1" = "tab2"."col2") RETURNING "tab1".* +-} deleteFrom :: ( SOP.SListI row , Has sch db schema - , Has tab schema ('Table table) ) - => QualifiedAlias sch tab -- ^ table to delete from + , Has tab0 schema ('Table table) ) + => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from -> UsingClause with db params from -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) -- ^ condition under which to delete a row - -> ReturningClause with db params '[tab ::: TableToRow table] row + -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return -> Manipulation with db params row -deleteFrom tab using wh returning = UnsafeManipulation $ +deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $ "DELETE FROM" - <+> renderSQL tab + <+> renderSQL tab0 <+> "AS" <+> renderSQL tab <> case using of NoUsing -> "" Using tables -> " USING" <+> renderSQL tables <+> "WHERE" <+> renderSQL wh <> renderSQL returning --- | Delete rows returning `Nil`. +{- | Delete rows returning `Nil`. + +>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[] + manp = deleteFrom_ (#tab `as` #t) (#t ! #col1 .== param @1) +in printSQL manp +:} +DELETE FROM "tab" AS "t" WHERE ("t"."col1" = ($1 :: int4)) +-} deleteFrom_ :: ( Has sch db schema - , Has tab schema ('Table table) ) - => QualifiedAlias sch tab -- ^ table to delete from + , Has tab0 schema ('Table table) ) + => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] -- ^ condition under which to delete a row -> Manipulation with db params '[] diff --git a/src/Squeal/PostgreSQL/Manipulation/Insert.hs b/src/Squeal/PostgreSQL/Manipulation/Insert.hs --- a/src/Squeal/PostgreSQL/Manipulation/Insert.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Insert.hs @@ -73,13 +73,29 @@ conceptually inserted one row at a time. Of course you can also insert more than one row, but there is no way to insert less than one row. Even if you know only some column values, a complete row must be created. + +>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext] +>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]] +>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] +>>> :{ +let + manp :: Manipulation with (Public CustomersSchema) '[] '[] + manp = + insertInto #customers + (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email)) + (OnConflict (OnConstraint #uq) + (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) [])) + (Returning_ Nil) +in printSQL manp +:} +INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) -} insertInto :: ( Has sch db schema - , Has tab schema ('Table table) + , Has tab0 schema ('Table table) , SOP.SListI (TableToColumns table) , SOP.SListI row ) - => QualifiedAlias sch tab + => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table -> QueryClause with db params (TableToColumns table) -- ^ what to insert @@ -88,18 +104,31 @@ -> ReturningClause with db params '[tab ::: TableToRow table] row -- ^ what to return -> Manipulation with db params row -insertInto tab qry conflict ret = UnsafeManipulation $ - "INSERT" <+> "INTO" <+> renderSQL tab +insertInto (tab0 `As` tab) qry conflict ret = UnsafeManipulation $ + "INSERT" <+> "INTO" + <+> renderSQL tab0 <+> "AS" <+> renderSQL tab <+> renderSQL qry <> renderSQL conflict <> renderSQL ret --- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`. +{- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`. + +>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + manp :: Manipulation with (Public Schema) '[] '[] + manp = + insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) +in printSQL manp +:} +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) +-} insertInto_ :: ( Has sch db schema - , Has tab schema ('Table table) + , Has tab0 schema ('Table table) , SOP.SListI (TableToColumns table) ) - => QualifiedAlias sch tab + => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table -> QueryClause with db params (TableToColumns table) -- ^ what to insert @@ -111,9 +140,9 @@ data QueryClause with db params columns where Values :: SOP.SListI columns - => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns + => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns -- ^ row of values - -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns] + -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns] -- ^ additional rows of values -> QueryClause with db params columns Select @@ -163,7 +192,7 @@ -- whose `ColumnsType` must match the tables'. pattern Values_ :: SOP.SListI columns - => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns + => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns -- ^ row of values -> QueryClause with db params columns pattern Values_ vals = Values vals [] diff --git a/src/Squeal/PostgreSQL/Manipulation/Update.hs b/src/Squeal/PostgreSQL/Manipulation/Update.hs --- a/src/Squeal/PostgreSQL/Manipulation/Update.hs +++ b/src/Squeal/PostgreSQL/Manipulation/Update.hs @@ -36,6 +36,7 @@ ) where import Data.ByteString hiding (foldr) +import GHC.TypeLits import qualified Generics.SOP as SOP @@ -61,37 +62,73 @@ UPDATE statements -----------------------------------------} --- | An `update` command changes the values of the specified columns --- in all rows that satisfy the condition. +{- | An `update` command changes the values of the specified columns +in all rows that satisfy the condition. + +>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] +>>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + manp :: Manipulation with (Public Schema) '[] + '["col1" ::: 'NotNull 'PGint4, + "col2" ::: 'NotNull 'PGint4] + manp = update + (#tab1 `as` #t1) + (Set (2 + #t2 ! #col2) `as` #col1) + (Using (table (#tab2 `as` #t2))) + (#t1 ! #col1 ./= #t2 ! #col2) + (Returning (#t1 & DotStar)) +in printSQL manp +:} +UPDATE "tab1" AS "t1" SET "col1" = ((2 :: int4) + "t2"."col2") FROM "tab2" AS "t2" WHERE ("t1"."col1" <> "t2"."col2") RETURNING "t1".* +-} update :: ( Has sch db schema - , Has tab schema ('Table table) + , Has tab0 schema ('Table table) , Updatable table updates , SOP.SListI row ) - => QualifiedAlias sch tab -- ^ table to update - -> NP (Aliased (Optional (Expression 'Ungrouped '[] '[] db params '[tab ::: TableToRow table]))) updates - -- ^ modified values to replace old values - -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] - -- ^ condition under which to perform update on a row - -> ReturningClause with db params '[tab ::: TableToRow table] row -- ^ results to return + => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update + -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)))) updates + -- ^ update expressions, modified values to replace old values + -> UsingClause with db params from + -- ^ FROM A table expression allowing columns from other tables to appear + -- in the WHERE condition and update expressions. + -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) + -- ^ WHERE condition under which to perform update on a row + -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return -> Manipulation with db params row -update tab columns wh returning = UnsafeManipulation $ +update (tab0 `As` tab) columns using wh returning = UnsafeManipulation $ "UPDATE" - <+> renderSQL tab + <+> renderSQL tab0 <+> "AS" <+> renderSQL tab <+> "SET" <+> renderCommaSeparated renderUpdate columns + <> case using of + NoUsing -> "" + Using tables -> " FROM" <+> renderSQL tables <+> "WHERE" <+> renderSQL wh <> renderSQL returning --- | Update a row returning `Nil`. +{- | Update a row returning `Nil`. + +>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + manp :: Manipulation with (Public Schema) '[] '[] + manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) +in printSQL manp +:} +UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") +-} update_ :: ( Has sch db schema - , Has tab schema ('Table table) + , Has tab0 schema ('Table table) + , KnownSymbol tab , Updatable table updates ) - => QualifiedAlias sch tab -- ^ table to update - -> NP (Aliased (Optional (Expression 'Ungrouped '[] '[] db params '[tab ::: TableToRow table]))) updates + => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update + -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[tab ::: TableToRow table]))) updates -- ^ modified values to replace old values -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] -- ^ condition under which to perform update on a row -> Manipulation with db params '[] -update_ tab columns wh = update tab columns wh (Returning_ Nil) +update_ tab columns wh = update tab columns NoUsing wh (Returning_ Nil) diff --git a/src/Squeal/PostgreSQL/Query.hs b/src/Squeal/PostgreSQL/Query.hs --- a/src/Squeal/PostgreSQL/Query.hs +++ b/src/Squeal/PostgreSQL/Query.hs @@ -33,8 +33,8 @@ module Squeal.PostgreSQL.Query ( -- * Query - Query_ - , Query (..) + Query (..) + , Query_ -- ** Set Operations , union , unionAll @@ -67,52 +67,13 @@ The general `Query` type is parameterized by - +* @lat :: FromType@ - scope for `Squeal.PostgreSQL.Query.From.Join.JoinLateral` and subquery expressions, * @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions, * @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s, * @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, * @row :: RowType@ - return type of the `Query`. --} -newtype Query - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (row :: RowType) - = UnsafeQuery { renderQuery :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (Query lat with db params row) where renderSQL = renderQuery -{- | -The top level `Query_` type is parameterized by a @db@ `SchemasType`, -against which the query is type-checked, an input @params@ Haskell `Type`, -and an ouput row Haskell `Type`. - -`Query_` is a type family which resolves into a `Query`, -so don't be fooled by the input params and output row Haskell `Type`s, -which are converted into appropriate -Postgres @[@`NullType`@]@ params and `RowType` rows. -Use a top-level `Squeal.PostgreSQL.Session.Statement.Statement` to -fix actual Haskell input params and output rows. - -A top-level `Query_` can be run -using `Squeal.PostgreSQL.Session.runQueryParams`, or if @params = ()@ -using `Squeal.PostgreSQL.Session.runQuery`. - -Generally, @params@ will be a Haskell tuple or record whose entries -may be referenced using positional -`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a -Haskell record, whose entries will be targeted using overloaded labels. - -Let's see some examples of queries. - ->>> :set -XDeriveAnyClass -XDerivingStrategies ->>> :{ -data Row a b = Row { col1 :: a, col2 :: b } - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} +Let's see some `Query` examples. simple query: @@ -120,9 +81,9 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = select Star (from (table #tab)) -in printSQL query + qry :: Query lat with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select Star (from (table #tab)) +in printSQL qry :} SELECT * FROM "tab" AS "tab" @@ -130,13 +91,13 @@ >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = + qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2) ( from (table #tab) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) ) -in printSQL query +in printSQL qry :} SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > (0 :: int4))) @@ -144,9 +105,9 @@ >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub))) -in printSQL query + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select Star (from (subquery (select Star (from (table #tab)) `as` #sub))) +in printSQL qry :} SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub" @@ -154,9 +115,9 @@ >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2) -in printSQL query + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2) +in printSQL qry :} SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4 @@ -164,9 +125,9 @@ >>> :{ let - query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32) - query = select Star (from (table #tab) & where_ (#col1 .> param @1)) -in printSQL query + qry :: Query '[] with (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select Star (from (table #tab) & where_ (#col1 .> param @1)) +in printSQL qry :} SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4)) @@ -174,13 +135,13 @@ >>> :{ let - query :: Query_ (Public Schema) () (Row Int64 Int32) - query = + qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint8, "col2" ::: 'NotNull 'PGint4] + qry = select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2) ( from (table (#tab `as` #table1)) & groupBy #col1 & having (sum_ (Distinct #col2) .> 1) ) -in printSQL query +in printSQL qry :} SELECT COALESCE(sum(ALL "col2"), (0 :: int8)) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > (1 :: int8)) @@ -188,9 +149,9 @@ >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = select Star (from (table #tab) & orderBy [#col1 & Asc]) -in printSQL query + qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select Star (from (table #tab) & orderBy [#col1 & Asc]) +in printSQL qry :} SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC @@ -207,8 +168,8 @@ >>> :{ type OrdersConstraints = '["pk_orders" ::: PrimaryKey '["id"] - ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"] - ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ] + ,"fk_customers" ::: ForeignKey '["customer_id"] "public" "customers" '["id"] + ,"fk_shippers" ::: ForeignKey '["shipper_id"] "public" "shippers" '["id"] ] :} >>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext] @@ -222,19 +183,17 @@ :} >>> :{ -data Order = Order - { price :: Float - , customerName :: Text - , shipperName :: Text - } deriving GHC.Generic -instance SOP.Generic Order -instance SOP.HasDatatypeInfo Order +type OrderRow = + '[ "price" ::: 'NotNull 'PGfloat4 + , "customerName" ::: 'NotNull 'PGtext + , "shipperName" ::: 'NotNull 'PGtext + ] :} >>> :{ let - query :: Query_ (Public OrdersSchema) () Order - query = select_ + qry :: Query lat with (Public OrdersSchema) params OrderRow + qry = select_ ( #o ! #price `as` #price :* #c ! #name `as` #customerName :* #s ! #name `as` #shipperName ) @@ -243,35 +202,19 @@ (#o ! #customer_id .== #c ! #id) & innerJoin (table (#shippers `as` #s)) (#o ! #shipper_id .== #s ! #id)) ) -in printSQL query +in printSQL qry :} SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id") ->>> :{ -let - query :: Query_ (Public OrdersSchema) () Order - query = select_ - ( #o ! #price `as` #price :* - #c ! #name `as` #customerName :* - #s ! #name `as` #shipperName ) - ( from (table (#orders `as` #o) - & (inner.JoinLateral) (select Star (from (table #customers)) `as` #c) - (#o ! #customer_id .== #c ! #id) - & (inner.JoinLateral) (select Star (from (table #shippers)) `as` #s) - (#o ! #shipper_id .== #s ! #id)) ) -in printSQL query -:} -SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN LATERAL (SELECT * FROM "customers" AS "customers") AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN LATERAL (SELECT * FROM "shippers" AS "shippers") AS "s" ON ("o"."shipper_id" = "s"."id") - self-join: >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = select + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2)))) -in printSQL query +in printSQL qry :} SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2" @@ -279,11 +222,11 @@ >>> :{ let - query :: Query_ db () (Row String Bool) - query = values + qry :: Query lat with db params '["col1" ::: 'NotNull 'PGtext, "col2" ::: 'NotNull 'PGbool] + qry = values ("true" `as` #col1 :* true `as` #col2) ["false" `as` #col1 :* false `as` #col2] -in printSQL query +in printSQL qry :} SELECT * FROM (VALUES ((E'true' :: text), TRUE), ((E'false' :: text), FALSE)) AS t ("col1", "col2") @@ -291,51 +234,114 @@ >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab)) -in printSQL query + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = select Star (from (table #tab)) `unionAll` select Star (from (table #tab)) +in printSQL qry :} (SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab") -with queries: +with query: >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int32) - query = with ( + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = with ( select Star (from (table #tab)) `as` #cte1 :>> select Star (from (common #cte1)) `as` #cte2 ) (select Star (from (common #cte2))) -in printSQL query +in printSQL qry :} WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" -window function queries +window functions: >>> :{ let - query :: Query_ (Public Schema) () (Row Int32 Int64) - query = select + qry :: Query '[] with (Public Schema) db '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint8] + qry = select (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc]))) (from (table #tab)) -in printSQL query +in printSQL qry :} SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab" -correlated subqueries +correlated subqueries: >>> :{ let - query :: Query_ (Public Schema) () (Only Int32) - query = - select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1)) + qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4] + qry = + select #col1 (from (table (#tab `as` #t1)) & where_ (exists ( select Star (from (table (#tab `as` #t2)) & where_ (#t2 ! #col2 .== #t1 ! #col1))))) -in printSQL query +in printSQL qry :} -SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1")) +SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1")) +-} +newtype Query + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (row :: RowType) + = UnsafeQuery { renderQuery :: ByteString } + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (Query lat with db params row) where renderSQL = renderQuery +{- | +The `Query_` type is parameterized by a @db@ `SchemasType`, +against which the query is type-checked, an input @params@ Haskell `Type`, +and an ouput row Haskell `Type`. + +A `Query_` can be run +using `Squeal.PostgreSQL.Session.runQueryParams`, or if @params = ()@ +using `Squeal.PostgreSQL.Session.runQuery`. + +Generally, @params@ will be a Haskell tuple or record whose entries +may be referenced using positional +`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a +Haskell record, whose entries will be targeted using overloaded labels. + +`Query_` is a type family which resolves into a `Query`, +so don't be fooled by the input params and output row Haskell `Type`s, +which are converted into appropriate +Postgres @[@`NullType`@]@ params and `RowType` rows. +Use `Squeal.PostgreSQL.Session.Statement.query` to +fix actual Haskell input params and output rows. + +>>> :set -XDeriveAnyClass -XDerivingStrategies +>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +data Row = Row { col1 :: Maybe Int64, col2 :: String } + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +:} + +>>> :{ +let + qry :: Query_ (Public Schema) (Int64, Bool) Row + qry = select Star (from (table #tab) & where_ (#col1 .> param @1 .&& notNull (param @2))) + stmt :: Statement (Public Schema) (Int64, Bool) Row + stmt = query qry +:} + +>>> :type qry +qry + :: Query + '[] + '[] + '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] + '[ 'NotNull 'PGint8, 'NotNull 'PGbool] + '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext] +>>> :type stmt +stmt + :: Statement + '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] + (Int64, Bool) + Row -} type family Query_ (db :: SchemasType) diff --git a/src/Squeal/PostgreSQL/Query/From.hs b/src/Squeal/PostgreSQL/Query/From.hs --- a/src/Squeal/PostgreSQL/Query/From.hs +++ b/src/Squeal/PostgreSQL/Query/From.hs @@ -82,7 +82,11 @@ table (tab `As` alias) = UnsafeFromClause $ renderSQL tab <+> "AS" <+> renderSQL alias --- | `subquery` derives a table from a `Query`. +{- | `subquery` derives a table from a `Query`. +The subquery may not reference columns provided by preceding `FromClause` items. +Use `Squeal.PostgreSQL.Query.From.Join.JoinLateral` +if the subquery must reference columns provided by preceding `FromClause` items. +-} subquery :: Aliased (Query lat with db params) query -- ^ aliased `Query` diff --git a/src/Squeal/PostgreSQL/Query/From/Join.hs b/src/Squeal/PostgreSQL/Query/From/Join.hs --- a/src/Squeal/PostgreSQL/Query/From/Join.hs +++ b/src/Squeal/PostgreSQL/Query/From/Join.hs @@ -81,8 +81,6 @@ -- ^ Subqueries can be preceded by `JoinLateral`. -- This allows them to reference columns provided -- by preceding `FromClause` items. - -- `subquery` is evaluated independently and so - -- cannot cross-reference any other `FromClause` item. -> JoinItem lat with db params left '[query] JoinFunction :: SetFun db arg set @@ -96,7 +94,7 @@ :: SListI args => SetFunN db args set -- ^ Set returning multi-argument functions - -- can be preceded by `JoinFunction`. + -- can be preceded by `JoinFunctionN`. -- This allows them to reference columns provided -- by preceding `FromClause` items. -> NP (Expression 'Ungrouped lat with db params left) args diff --git a/src/Squeal/PostgreSQL/Query/Select.hs b/src/Squeal/PostgreSQL/Query/Select.hs --- a/src/Squeal/PostgreSQL/Query/Select.hs +++ b/src/Squeal/PostgreSQL/Query/Select.hs @@ -103,24 +103,24 @@ (Expression grp lat with db params from ty) (Selection grp lat with db params from row) where expr `as` col = List (expr `as` col) -instance (Has tab (Join lat from) row0, Has col row0 ty, row1 ~ '[col ::: ty]) +instance (Has tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty]) => IsQualified tab col (Selection 'Ungrouped lat with db params from row1) where tab ! col = tab ! col `as` col instance - ( Has tab (Join lat from) row0 + ( Has tab (Join from lat) row0 , Has col row0 ty , row1 ~ '[col ::: ty] , GroupedBy tab col bys ) => IsQualified tab col (Selection ('Grouped bys) lat with db params from row1) where tab ! col = tab ! col `as` col -instance (HasUnique tab (Join lat from) row0, Has col row0 ty, row1 ~ '[col ::: ty]) +instance (HasUnique tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty]) => IsLabel col (Selection 'Ungrouped lat with db params from row1) where fromLabel = fromLabel @col `as` Alias instance - ( HasUnique tab (Join lat from) row0 + ( HasUnique tab (Join from lat) row0 , Has col row0 ty , row1 ~ '[col ::: ty] , GroupedBy tab col bys ) diff --git a/src/Squeal/PostgreSQL/Query/Table.hs b/src/Squeal/PostgreSQL/Query/Table.hs --- a/src/Squeal/PostgreSQL/Query/Table.hs +++ b/src/Squeal/PostgreSQL/Query/Table.hs @@ -40,10 +40,15 @@ , having , limit , offset + , lockRows -- * Grouping , By (..) , GroupByClause (..) , HavingClause (..) + -- * Row Locks + , LockingClause (..) + , LockStrength (..) + , Waiting (..) ) where import Control.DeepSeq @@ -72,7 +77,7 @@ -- | A `TableExpression` computes a table. The table expression contains -- a `fromClause` that is optionally followed by a `whereClause`, -- `groupByClause`, `havingClause`, `orderByClause`, `limitClause` --- and `offsetClause`s. Trivial table expressions simply refer +-- `offsetClause` and `lockingClauses`. Trivial table expressions simply refer -- to a table on disk, a so-called base table, but more complex expressions -- can be used to modify or combine base tables in various ways. data TableExpression @@ -122,19 +127,22 @@ -- if nonempty. The offset count says to skip that many rows before -- beginning to return rows. The rows are skipped before the limit count -- is applied. + , lockingClauses :: [LockingClause from] + -- ^ `lockingClauses` can be added to a table expression with `lockRows`. } deriving (GHC.Generic) -- | Render a `TableExpression` instance RenderSQL (TableExpression grp lat with db params from) where renderSQL - (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat + (TableExpression frm' whs' grps' hvs' srts' lims' offs' lks') = mconcat [ "FROM ", renderSQL frm' , renderWheres whs' , renderSQL grps' , renderSQL hvs' , renderSQL srts' , renderLimits lims' - , renderOffsets offs' ] + , renderOffsets offs' + , renderLocks lks' ] where renderWheres = \case [] -> "" @@ -145,6 +153,7 @@ renderOffsets = \case [] -> "" offs -> " OFFSET" <+> fromString (show (sum offs)) + renderLocks = foldr (\l b -> b <+> renderSQL l) "" -- | A `from` generates a `TableExpression` from a table reference that can be -- a table name, or a derived table such as a subquery, a JOIN construct, @@ -155,7 +164,7 @@ from :: FromClause lat with db params from -- ^ table reference -> TableExpression 'Ungrouped lat with db params from -from tab = TableExpression tab [] noGroups NoHaving [] [] [] +from tab = TableExpression tab [] noGroups NoHaving [] [] [] [] -- | A `where_` is an endomorphism of `TableExpression`s which adds a -- search condition to the `whereClause`. @@ -181,6 +190,7 @@ , orderByClause = [] , limitClause = limitClause rels , offsetClause = offsetClause rels + , lockingClauses = lockingClauses rels } -- | A `having` is an endomorphism of `TableExpression`s which adds a @@ -211,6 +221,22 @@ -> TableExpression grp lat with db params from offset off rels = rels {offsetClause = off : offsetClause rels} +{- | Add a `LockingClause` to a `TableExpression`. +Multiple `LockingClause`s can be written if it is necessary +to specify different locking behavior for different tables. +If the same table is mentioned (or implicitly affected) +by more than one locking clause, then it is processed +as if it was only specified by the strongest one. +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. +-} +lockRows + :: LockingClause from -- ^ row-level lock + -> TableExpression grp lat with db params from + -> TableExpression grp lat with db params from +lockRows lck tab = tab {lockingClauses = lck : lockingClauses tab} + {----------------------------------------- Grouping -----------------------------------------} @@ -287,3 +313,96 @@ Having [] -> "" Having conditions -> " HAVING" <+> commaSeparated (renderSQL <$> conditions) + +{- | +If specific tables are named in a locking clause, +then only rows coming from those tables are locked; +any other tables used in the `Squeal.PostgreSQL.Query.Select.select` are simply read as usual. +A locking clause with a `Nil` table list affects all tables used in the statement. +If a locking clause is applied to a `view` or `subquery`, +it affects all tables used in the `view` or `subquery`. +However, these clauses do not apply to `Squeal.PostgreSQL.Query.With.with` queries referenced by the primary query. +If you want row locking to occur within a `Squeal.PostgreSQL.Query.With.with` query, +specify a `LockingClause` within the `Squeal.PostgreSQL.Query.With.with` query. +-} +data LockingClause from where + For + :: HasAll tabs from tables + => LockStrength -- ^ lock strength + -> NP Alias tabs -- ^ table list + -> Waiting -- ^ wait or not + -> LockingClause from +instance RenderSQL (LockingClause from) where + renderSQL (For str tabs wt) = + "FOR" <+> renderSQL str + <> case tabs of + Nil -> "" + _ -> " OF" <+> renderSQL tabs + <> renderSQL wt + +{- | +Row-level locks, which are listed as below with the contexts +in which they are used automatically by PostgreSQL. +Note that a transaction can hold conflicting locks on the same row, +even in different subtransactions; but other than that, +two transactions can never hold conflicting locks on the same row. +Row-level locks do not affect data querying; +they block only writers and lockers to the same row. +Row-level locks are released at transaction end or during savepoint rollback. +-} +data LockStrength + = Update + {- ^ `For` `Update` causes the rows retrieved by the `Squeal.PostgreSQL.Query.Select.select` statement + to be locked as though for update. This prevents them from being locked, + modified or deleted by other transactions until the current transaction ends. + That is, other transactions that attempt `Squeal.PostgreSQL.Manipulation.Update.update`, `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, + `Squeal.PostgreSQL.Query.Select.select` `For` `Update`, `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`, + `Squeal.PostgreSQL.Query.Select.select` `For` `Share` or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` of these rows will be blocked + until the current transaction ends; conversely, `Squeal.PostgreSQL.Query.Select.select` `For` `Update` will wait + for a concurrent transaction that has run any of those commands on the same row, + and will then lock and return the updated row (or no row, if the row was deleted). + Within a `Squeal.PostgreSQL.Session.Transaction.RepeatableRead` or `Squeal.PostgreSQL.Session.Transaction.Serializable` transaction, however, an error will be + thrown if a row to be locked has changed since the transaction started. + + The `For` `Update` lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` a row, + and also by an `Update` that modifies the values on certain columns. + Currently, the set of columns considered for the `Squeal.PostgreSQL.Manipulation.Update.update` case are those + that have a unique index on them that can be used in a foreign key + (so partial indexes and expressional indexes are not considered), + but this may change in the future.-} + | NoKeyUpdate + {- | Behaves similarly to `For` `Update`, except that the lock acquired is weaker: + this lock will not block `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` commands that attempt to acquire + a lock on the same rows. This lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Update.update` + that does not acquire a `For` `Update` lock.-} + | Share + {- | Behaves similarly to `For` `Share`, except that the lock is weaker: + `Squeal.PostgreSQL.Query.Select.select` `For` `Update` is blocked, but not `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`. + A key-shared lock blocks other transactions from performing + `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` or any `Squeal.PostgreSQL.Manipulation.Update.update` that changes the key values, + but not other `Update`, and neither does it prevent `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`, + `Squeal.PostgreSQL.Query.Select.select` `For` `Share`, or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare`.-} + | KeyShare + deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) +instance RenderSQL LockStrength where + renderSQL = \case + Update -> "UPDATE" + NoKeyUpdate -> "NO KEY UPDATE" + Share -> "SHARE" + KeyShare -> "KEY SHARE" + +-- | To prevent the operation from `Waiting` for other transactions to commit, +-- use either the `NoWait` or `SkipLocked` option. +data Waiting + = Wait + -- ^ wait for other transactions to commit + | NoWait + -- ^ reports an error, rather than waiting + | SkipLocked + -- ^ any selected rows that cannot be immediately locked are skipped + deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) +instance RenderSQL Waiting where + renderSQL = \case + Wait -> "" + NoWait -> " NOWAIT" + SkipLocked -> " SKIP LOCKED" diff --git a/src/Squeal/PostgreSQL/Query/With.hs b/src/Squeal/PostgreSQL/Query/With.hs --- a/src/Squeal/PostgreSQL/Query/With.hs +++ b/src/Squeal/PostgreSQL/Query/With.hs @@ -50,9 +50,42 @@ -- $setup -- >>> import Squeal.PostgreSQL --- | `with` provides a way to write auxiliary statements for use in a larger query. --- These statements, referred to as `CommonTableExpression`s, can be thought of as --- defining temporary tables that exist just for one query. +{- | `with` provides a way to write auxiliary statements for use in a larger query. +These statements, referred to as `CommonTableExpression`s, can be thought of as +defining temporary tables that exist just for one query. + +`with` can be used for a `Query`. Multiple `CommonTableExpression`s can be +chained together with the `Path` constructor `:>>`, and each `CommonTableExpression` +is constructed via overloaded `as`. + +>>> 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 :>> + select Star (from (common #cte1)) `as` #cte2 + ) (select Star (from (common #cte2))) +in printSQL qry +:} +WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" + +You can use data-modifying statements in `with`. This allows you to perform several +different operations in the same query. An example is: + +>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate] +>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)] +>>> :{ +let + manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[] + manp = with + (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del) + (insertInto_ #products_deleted (Subquery (select Star (from (common #del))))) +in printSQL manp +:} +WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del" +-} class With statement where with :: Path (CommonTableExpression statement db params) with0 with1 @@ -65,21 +98,30 @@ with ctes query = UnsafeQuery $ "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL query -{- | +{- | A `withRecursive` `Query` can refer to its own output. +A very simple example is this query to sum the integers from 1 through 100: + >>> import Data.Monoid (Sum (..)) >>> import Data.Int (Int64) >>> :{ let - query :: Query_ schema () (Sum Int64) - query = withRecursive - ( values_ ((1 & astype int) `as` #n) - `unionAll` - select_ ((#n + 1) `as` #n) - (from (common #t) & where_ (#n .< 100)) `as` #t ) - ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil)) - in printSQL query + sum100 :: Statement db () (Sum Int64) + sum100 = query $ + withRecursive + ( values_ ((1 & astype int) `as` #n) + `unionAll` + select_ ((#n + 1) `as` #n) + (from (common #t) & where_ (#n .< 100)) `as` #t ) + ( select_ + (fromNull 0 (sum_ (All #n)) `as` #getSum) + (from (common #t) & groupBy Nil) ) + in printSQL sum100 :} WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (((1 :: int4) :: int))) AS t ("n")) UNION ALL (SELECT ("n" + (1 :: int4)) AS "n" FROM "t" AS "t" WHERE ("n" < (100 :: int4)))) SELECT COALESCE(sum(ALL "n"), (0 :: int8)) AS "getSum" FROM "t" AS "t" + +The general form of a recursive WITH query is always a non-recursive term, +then `union` (or `unionAll`), then a recursive term, where +only the recursive term can contain a reference to the query's own output. -} withRecursive :: Aliased (Query lat (recursive ': with) db params) recursive diff --git a/src/Squeal/PostgreSQL/Session.hs b/src/Squeal/PostgreSQL/Session.hs --- a/src/Squeal/PostgreSQL/Session.hs +++ b/src/Squeal/PostgreSQL/Session.hs @@ -6,8 +6,8 @@ Stability: experimental Using Squeal in your application will come down to defining -the @db@ of your database and including @PQ db db@ in your -application's monad transformer stack, giving it an instance of `MonadPQ`. +the @DB :: @`SchemasType` of your database and including @PQ DB DB@ in your +application's monad transformer stack, giving it an instance of `MonadPQ` @DB@. -} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -38,9 +38,12 @@ ) where import Control.Category +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..), MonadMask(..)) import Control.Monad.Except import Control.Monad.Morph import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) import UnliftIO (MonadUnliftIO (..), bracket, throwIO) import Data.ByteString (ByteString) import Data.Foldable @@ -260,6 +263,53 @@ withRunInIO inner = PQ $ \conn -> withRunInIO $ \(run :: (forall x . m x -> IO x)) -> K <$> inner (\pq -> run $ unK <$> unPQ pq conn) + +instance (MonadBase b m) + => MonadBase b (PQ schema schema m) where + liftBase = lift . liftBase + +instance db0 ~ db1 => MonadTransControl (PQ db0 db1) where + type StT (PQ db0 db1) a = a + liftWith f = PQ $ \conn -> K <$> (f $ \pq -> unK <$> unPQ pq conn) + restoreT ma = PQ . const $ K <$> ma + +-- | A snapshot of the state of a `PQ` computation, used in MonadBaseControl Instance +type PQRun schema = + forall m x. Monad m => PQ schema schema m x -> m (K x schema) + +instance (MonadBaseControl b m, schema0 ~ schema1) + => MonadBaseControl b (PQ schema0 schema1 m) where + type StM (PQ schema0 schema1 m) x = StM m (K x schema0) + restoreM = PQ . const . restoreM + liftBaseWith f = + pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run + where + pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a + pqliftWith g = PQ $ \ conn -> + fmap K (g $ \ pq -> unPQ pq conn) + +instance (MonadThrow m, db0 ~ db1) + => MonadThrow (PQ db0 db1 m) where + throwM = lift . throwM + +instance (MonadCatch m, db0 ~ db1) + => MonadCatch (PQ db0 db1 m) where + catch (PQ m) f = PQ $ \k -> m k `catch` \e -> unPQ (f e) k + +instance (MonadMask m, db0 ~ db1) + => MonadMask (PQ db0 db1 m) where + mask a = PQ $ \e -> mask $ \u -> unPQ (a $ q u) e + where q u (PQ b) = PQ (u . b) + + uninterruptibleMask a = + PQ $ \k -> uninterruptibleMask $ \u -> unPQ (a $ q u) k + where q u (PQ b) = PQ (u . b) + + generalBracket acquire release use = PQ $ \k -> + K <$> generalBracket + (unK <$> unPQ acquire k) + (\resource exitCase -> unK <$> unPQ (release resource exitCase) k) + (\resource -> unK <$> unPQ (use resource) k) instance (Monad m, Semigroup r, db0 ~ db1) => Semigroup (PQ db0 db1 m r) where f <> g = pqAp (fmap (<>) f) g diff --git a/src/Squeal/PostgreSQL/Session/Connection.hs b/src/Squeal/PostgreSQL/Session/Connection.hs --- a/src/Squeal/PostgreSQL/Session/Connection.hs +++ b/src/Squeal/PostgreSQL/Session/Connection.hs @@ -55,7 +55,7 @@ >>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]] >>> :set -XTypeApplications >>> :set -XOverloadedStrings ->>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb" +>>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Note that, for now, squeal doesn't offer any protection from connecting with the wrong schema! diff --git a/src/Squeal/PostgreSQL/Session/Decode.hs b/src/Squeal/PostgreSQL/Session/Decode.hs --- a/src/Squeal/PostgreSQL/Session/Decode.hs +++ b/src/Squeal/PostgreSQL/Session/Decode.hs @@ -32,11 +32,14 @@ FromPG (..) , devalue , rowValue + , enumValue -- * Decode Rows , DecodeRow (..) , decodeRow , runDecodeRow , genericRow + , appendRows + , consRow -- * Decoding Classes , FromValue (..) , FromField (..) @@ -57,6 +60,8 @@ import Data.Int (Int16, Int32, Int64) import Data.Kind import Data.Scientific (Scientific) +import Data.String (fromString) +import Data.Text (Text) import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime) import Data.UUID.Types (UUID) import Data.Vector (Vector) @@ -153,14 +158,14 @@ , imaginary :: Double } deriving stock GHC.Generic deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG) via (Composite Complex) + deriving (IsPG, FromPG) via Composite Complex :} >>> :{ data Direction = North | South | East | West deriving stock GHC.Generic deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG) via (Enumerated Direction) + deriving (IsPG, FromPG) via Enumerated Direction :} -} @@ -199,6 +204,30 @@ fromPG = devalue bytea_strict instance FromPG Lazy.ByteString where fromPG = devalue bytea_lazy +instance KnownNat n => FromPG (VarChar n) where + fromPG = devalue $ text_strict >>= \t -> + case varChar t of + Nothing -> throwError $ Strict.Text.pack $ concat + [ "Source for VarChar has wrong length" + , "; expected length " + , show (natVal (SOP.Proxy @n)) + , ", actual length " + , show (Strict.Text.length t) + , "." + ] + Just x -> pure x +instance KnownNat n => FromPG (FixChar n) where + fromPG = devalue $ text_strict >>= \t -> + case fixChar t of + Nothing -> throwError $ Strict.Text.pack $ concat + [ "Source for FixChar has wrong length" + , "; expected length " + , show (natVal (SOP.Proxy @n)) + , ", actual length " + , show (Strict.Text.length t) + , "." + ] + Just x -> pure x instance FromPG Day where fromPG = devalue date instance FromPG TimeOfDay where @@ -385,6 +414,8 @@ , Monad , MonadPlus , MonadError Strict.Text ) +instance MonadFail (DecodeRow row) where + fail = throwError . fromString -- | Run a `DecodeRow`. runDecodeRow @@ -393,6 +424,67 @@ -> Either Strict.Text y runDecodeRow = fmap runExcept . runReaderT . unDecodeRow +{- | Append two row decoders with a combining function. + +>>> import GHC.Generics as GHC +>>> :{ +data L = L {fst :: Int16, snd :: 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) +type Row = '[ + "fst" ::: 'NotNull 'PGint2, + "snd" ::: 'NotNull ('PGchar 1), + "thrd" ::: 'NotNull 'PGbool, + "frth" ::: 'NotNull 'PGbool] +:} + +>>> :{ +let + decode :: DecodeRow Row (L,R) + decode = appendRows (,) genericRow genericRow + row4 = + SOP.K (Just "\NUL\SOH") :* + SOP.K (Just "a") :* + SOP.K (Just "\NUL") :* + SOP.K (Just "\NUL") :* Nil +in runDecodeRow decode row4 +:} +Right (L {fst = 1, snd = 'a'},R {thrd = False, frth = False}) +-} +appendRows + :: SOP.SListI left + => (l -> r -> z) -- ^ combining function + -> DecodeRow left l -- ^ left decoder + -> DecodeRow right r -- ^ right decoder + -> DecodeRow (Join left right) z +appendRows f decL decR = decodeRow $ \row -> case disjoin row of + (rowL, rowR) -> f <$> runDecodeRow decL rowL <*> runDecodeRow decR rowR + +{- | Cons a column and a row decoder with a combining function. + +>>> :{ +let + decode :: DecodeRow + '["fst" ::: 'NotNull 'PGtext, "snd" ::: 'NotNull 'PGint2, "thrd" ::: 'NotNull ('PGchar 1)] + (String, (Int16, Char)) + decode = consRow (,) #fst (consRow (,) #snd #thrd) +in runDecodeRow decode (SOP.K (Just "hi") :* SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil) +:} +Right ("hi",(1,'a')) +-} +consRow + :: FromValue head h + => (h -> t -> z) -- ^ combining function + -> Alias col -- ^ alias of head + -> DecodeRow tail t -- ^ tail decoder + -> DecodeRow (col ::: head ': tail) z +consRow f _ dec = decodeRow $ \case + (SOP.K h :: SOP.K (Maybe Strict.ByteString) (col ::: head)) :* t + -> f <$> fromValue @head h <*> runDecodeRow dec t + -- | Smart constructor for a `DecodeRow`. decodeRow :: (SOP.NP (SOP.K (Maybe Strict.ByteString)) row -> Either Strict.Text y) @@ -443,3 +535,33 @@ => SOP.K (Maybe Strict.ByteString) ty -> Except Strict.Text (SOP.P y) runField = liftEither . fromField @ty . SOP.unK + +{- | +>>> :{ +data Dir = North | East | South | West +instance IsPG Dir where + type PG Dir = 'PGenum '["north", "south", "east", "west"] +instance FromPG Dir where + fromPG = enumValue $ + label @"north" North :* + label @"south" South :* + label @"east" East :* + label @"west" West +:} +-} +enumValue + :: (SOP.All KnownSymbol labels, PG y ~ 'PGenum labels) + => NP (SOP.K y) labels + -> StateT Strict.ByteString (Except Strict.Text) y +enumValue = devalue . enum . labels + where + labels + :: SOP.All KnownSymbol labels + => NP (SOP.K y) labels + -> Text -> Maybe y + labels = \case + Nil -> \_ -> Nothing + ((y :: SOP.K y label) :* ys) -> \ str -> + if str == fromString (symbolVal (SOP.Proxy @label)) + then Just (SOP.unK y) + else labels ys str diff --git a/src/Squeal/PostgreSQL/Session/Encode.hs b/src/Squeal/PostgreSQL/Session/Encode.hs --- a/src/Squeal/PostgreSQL/Session/Encode.hs +++ b/src/Squeal/PostgreSQL/Session/Encode.hs @@ -85,7 +85,7 @@ -- into the binary format of a PostgreSQL `PGType`. class IsPG x => ToPG (db :: SchemasType) (x :: Type) where -- | >>> :set -XTypeApplications -XDataKinds - -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" + -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" -- >>> runReaderT (toPG @'[] False) conn -- "\NUL" -- @@ -120,6 +120,8 @@ toPG = pure . text_strict . Strict.Text.pack instance ToPG db Strict.ByteString where toPG = pure . bytea_strict 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 Day where toPG = pure . date instance ToPG db TimeOfDay where toPG = pure . time_int instance ToPG db (TimeOfDay, TimeZone) where toPG = pure . timetz_int @@ -309,7 +311,7 @@ `EncodeParams` describes an encoding of a Haskell `Type` into a list of parameter `NullType`s. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] @@ -336,7 +338,7 @@ >>> 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" +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two @@ -374,7 +376,7 @@ {- | Cons a parameter encoding. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] @@ -398,7 +400,7 @@ {- | End a parameter encoding. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] @@ -422,7 +424,7 @@ {- | Encode 1 parameter. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] '[ 'NotNull 'PGint4] Int32 @@ -441,7 +443,7 @@ {- | Append parameter encodings. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] diff --git a/src/Squeal/PostgreSQL/Session/Migration.hs b/src/Squeal/PostgreSQL/Session/Migration.hs --- a/src/Squeal/PostgreSQL/Session/Migration.hs +++ b/src/Squeal/PostgreSQL/Session/Migration.hs @@ -26,7 +26,7 @@ >>> :{ type EmailsTable = '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 @@ -71,7 +71,7 @@ nullable text `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) + (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) , down = dropTable #emails } :} @@ -84,7 +84,7 @@ >>> import Control.Monad.IO.Class >>> :{ -withConnection "host=localhost port=5432 dbname=exampledb" $ +withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;") -- suppress notices & pqThen (liftIO (putStrLn "Migrate")) @@ -97,7 +97,7 @@ We can also create a simple executable using `mainMigrateIso`. ->>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb" migrations +>>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" migrations >>> withArgs [] main Invalid command: "". Use: @@ -211,9 +211,9 @@ -- | A `Migration` consists of a name and a migration definition. data Migration def db0 db1 = Migration - { name :: Text -- ^ The `name` of a `Migration`. - -- Each `name` in a `Migration` should be unique. - , migration :: def db0 db1 -- ^ The migration of a `Migration`. + { migrationName :: Text -- ^ The name of a `Migration`. + -- Each `migrationName` should be unique. + , migrationDef :: def db0 db1 -- ^ The migration of a `Migration`. } deriving (GHC.Generic) instance QFunctor Migration where qmap f (Migration n i) = Migration n (f i) @@ -233,11 +233,11 @@ where upMigration step = do executed <- do - result <- executeParams selectMigration (name step) + result <- executeParams selectMigration (migrationName step) ntuples (result :: Result UTCTime) unless (executed == 1) $ do - _ <- unsafePQ . runIndexed $ migration step - executeParams_ insertMigration (name step) + _ <- unsafePQ . runIndexed $ migrationDef step + executeParams_ insertMigration (migrationName step) -- | pure migrations instance Migratory Definition (Indexed PQ IO ()) where runMigrations = runMigrations . qmap (qmap ixDefine) @@ -249,11 +249,11 @@ where downMigration (OpQ step) = do executed <- do - result <- executeParams selectMigration (name step) + result <- executeParams selectMigration (migrationName step) ntuples (result :: Result UTCTime) unless (executed == 0) $ do - _ <- unsafePQ . runIndexed . getOpQ $ migration step - executeParams_ deleteMigration (name step) + _ <- unsafePQ . runIndexed . getOpQ $ migrationDef step + executeParams_ deleteMigration (migrationName step) -- | pure rewinds instance Migratory (OpQ Definition) (OpQ (Indexed PQ IO ())) where runMigrations = runMigrations . qmap (qmap (qmap ixDefine)) @@ -303,8 +303,8 @@ ] data MigrationRow = - MigrationRow { migrationName :: Text - , migrationTime :: UTCTime } + MigrationRow { name :: Text + , executed_at :: UTCTime } deriving (GHC.Generic, Show) instance SOP.Generic MigrationRow @@ -344,9 +344,7 @@ & where_ (#name .== param @1) selectMigrations :: Statement MigrationsSchemas () MigrationRow -selectMigrations = query $ - select_ (#name `as` #migrationName :* #executed_at `as` #migrationTime) - (from (table #schema_migrations)) +selectMigrations = query $ select Star (from (table #schema_migrations)) {- | `mainMigrate` creates a simple executable from a connection string and a `Path` of `Migration`s. -} @@ -376,7 +374,7 @@ migrateStatus :: PQ schema schema IO () migrateStatus = unsafePQ $ do runNames <- getRunMigrationNames - let names = qtoList name migrations + let names = qtoList migrationName migrations unrunNames = names \\ runNames liftIO $ displayRunned runNames >> displayUnrunned unrunNames @@ -420,7 +418,7 @@ migrateStatus :: PQ schema schema IO () migrateStatus = unsafePQ $ do runNames <- getRunMigrationNames - let names = qtoList name migrations + let names = qtoList migrationName migrations unrunNames = names \\ runNames liftIO $ displayRunned runNames >> displayUnrunned unrunNames @@ -437,7 +435,7 @@ getRunMigrationNames :: PQ db0 db0 IO [Text] getRunMigrationNames = - fmap migrationName <$> + fmap name <$> (unsafePQ (define createMigrations & pqThen (execute selectMigrations)) >>= getRows) diff --git a/src/Squeal/PostgreSQL/Session/Monad.hs b/src/Squeal/PostgreSQL/Session/Monad.hs --- a/src/Squeal/PostgreSQL/Session/Monad.hs +++ b/src/Squeal/PostgreSQL/Session/Monad.hs @@ -52,6 +52,9 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict +-- $setup +-- >>> import Squeal.PostgreSQL + {- | `MonadPQ` is an @mtl@ style constraint, similar to `Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to run `Statement`s. @@ -59,30 +62,108 @@ class Monad pq => MonadPQ db pq | pq -> db where {- | - `executeParams` runs a `Statement`. - It calls `LibPQ.execParams` and doesn't afraid of anything. + `executeParams` runs a `Statement` which takes out-of-line + `Squeal.PostgreSQL.Expression.Parameter.parameter`s. + + >>> 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 + result <- executeParams sumOf (2,2) + firstRow result + :} + Just (Sum {getSum = 4}) -} - executeParams :: Statement db x y -> x -> pq (Result y) + executeParams + :: Statement db x y + -- ^ query or manipulation + -> x + -- ^ parameters + -> pq (Result y) default executeParams :: (MonadTrans t, MonadPQ db m, pq ~ t m) - => Statement db x y -> x -> pq (Result y) + => Statement db x y + -- ^ query or manipulation + -> x + -- ^ parameters + -> pq (Result y) executeParams statement params = lift $ executeParams statement params {- | `executeParams_` runs a returning-free `Statement`. - It calls `LibPQ.execParams` and doesn't afraid of anything. + + >>> 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 (executeParams_ insertion (2,2)) + & pqThen (define teardown) + :} -} - executeParams_ :: Statement db x () -> x -> pq () + executeParams_ + :: Statement db x () + -- ^ query or manipulation + -> x + -- ^ parameters + -> pq () executeParams_ statement params = void $ executeParams statement params - {- | - `execute` runs a parameter-free `Statement`. + {- | `execute` runs a parameter-free `Statement`. + + >>> import Data.Int(Int32) + >>> :{ + let + two :: Expr ('NotNull 'PGint4) + two = 2 + twoPlusTwo :: Statement db () (Only Int32) + twoPlusTwo = query $ values_ $ (two + two) `as` #fromOnly + in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do + result <- execute twoPlusTwo + firstRow result + :} + Just (Only {fromOnly = 4}) -} - execute :: Statement db () y -> pq (Result y) + execute + :: Statement db () y + -- ^ query or manipulation + -> pq (Result y) execute statement = executeParams statement () - {- | - `execute_` runs a parameter-free, returning-free `Statement`. + {- | `execute_` runs a parameter-free, returning-free `Statement`. + + >>> :{ + let + silence :: Statement db () () + silence = manipulation $ + UnsafeManipulation "Set client_min_messages TO WARNING" + in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ execute_ silence + :} -} execute_ :: Statement db () () -> pq () execute_ = void . execute @@ -91,32 +172,124 @@ `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 :: Traversable list - => Statement db x y -> list x -> pq (list (Result y)) + => Statement db x y + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq (list (Result y)) default executePrepared :: (MonadTrans t, MonadPQ db m, pq ~ t m) => Traversable list - => Statement db x y -> list x -> pq (list (Result y)) + => Statement db x y + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq (list (Result y)) executePrepared statement x = lift $ executePrepared statement x {- | `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_ :: Foldable list - => Statement db x () -> list x -> pq () + => 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 () -> list x -> pq () + => Statement db x () + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq () executePrepared_ statement x = lift $ executePrepared_ statement x {- | `manipulateParams` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`. + +>>> type Column = 'NoDef :=> 'NotNull 'PGint4 +>>> type Columns = '["col1" ::: Column, "col2" ::: Column] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> type DB = Public Schema +>>> import Control.Monad.IO.Class +>>> import Data.Int(Int32) +>>> :{ +let + insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32) + insertAdd = insertInto #tab + ( Values_ $ + Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* + Set (param @2 @('NotNull 'PGint4)) `as` #col2 + ) OnConflictDoRaise + ( Returning_ ((#col1 + #col2) `as` #fromOnly) ) + 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 + ( do + result <- manipulateParams insertAdd (2::Int32,2::Int32) + Just (Only answer) <- firstRow result + liftIO $ print (answer :: Int32) + ) + & pqThen (define teardown) +:} +4 -} manipulateParams :: ( MonadPQ db pq @@ -132,6 +305,31 @@ {- | `manipulateParams_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, for a returning-free statement. + +>>> 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 :: Manipulation_ DB (Int32, Int32) () + insertion = 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 (manipulateParams_ insertion (2::Int32,2::Int32)) + & pqThen (define teardown) +:} -} manipulateParams_ :: ( MonadPQ db pq @@ -146,6 +344,39 @@ {- | `manipulate` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, for a parameter-free statement. + +>>> type Column = 'NoDef :=> 'NotNull 'PGint4 +>>> type Columns = '["col1" ::: Column, "col2" ::: Column] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> type DB = Public Schema +>>> import Control.Monad.IO.Class +>>> import Data.Int(Int32) +>>> :{ +let + insertTwoPlusTwo :: Manipulation_ DB () (Only Int32) + insertTwoPlusTwo = insertInto #tab + (Values_ $ Set 2 `as` #col1 :* Set 2 `as` #col2) + OnConflictDoRaise + (Returning_ ((#col1 + #col2) `as` #fromOnly)) + 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 + ( do + result <- manipulate insertTwoPlusTwo + Just (Only answer) <- firstRow result + liftIO $ print (answer :: Int32) + ) + & pqThen (define teardown) +:} +4 -} manipulate :: (MonadPQ db pq, GenericRow row y ys) @@ -156,6 +387,14 @@ {- | `manipulate_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, for a returning-free, parameter-free statement. + +>>> :{ +let + silence :: Manipulation_ db () () + silence = UnsafeManipulation "Set client_min_messages TO WARNING" +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ manipulate_ silence +:} -} manipulate_ :: MonadPQ db pq @@ -165,6 +404,24 @@ {- | `runQueryParams` runs a `Squeal.PostgreSQL.Query.Query`. + +>>> import Data.Int (Int32, Int64) +>>> import Control.Monad.IO.Class +>>> import Data.Monoid (Sum(Sum)) +>>> :{ +let + sumOf :: Query_ db (Int32, Int32) (Sum Int32) + sumOf = values_ $ + ( param @1 @('NotNull 'PGint4) + + param @2 @('NotNull 'PGint4) + ) `as` #getSum +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do + result <- runQueryParams sumOf (2::Int32,2::Int32) + Just (Sum four) <- firstRow result + liftIO $ print (four :: Int32) +:} +4 -} runQueryParams :: ( MonadPQ db pq @@ -179,6 +436,21 @@ {- | `runQuery` runs a `Squeal.PostgreSQL.Query.Query`, for a parameter-free statement. + +>>> import Data.Int (Int32, Int64) +>>> import Control.Monad.IO.Class +>>> import Data.Monoid (Sum(Sum)) +>>> :{ +let + twoPlusTwo :: Query_ db () (Sum Int32) + twoPlusTwo = values_ $ (2 + 2) `as` #getSum +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do + result <- runQuery twoPlusTwo + Just (Sum four) <- firstRow result + liftIO $ print (four :: Int32) +:} +4 -} runQuery :: (MonadPQ db pq, SOP.IsRecord y ys, SOP.AllZip FromField row ys) @@ -191,6 +463,41 @@ `traversePrepared` runs a `Squeal.PostgreSQL.Manipulation.Manipulation` on a `Traversable` 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 Control.Monad.IO.Class +>>> import Data.Int(Int32) +>>> :{ +let + insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32) + insertAdd = insertInto #tab + ( Values_ $ + Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* + Set (param @2 @('NotNull 'PGint4)) `as` #col2 + ) OnConflictDoRaise + ( Returning_ ((#col1 + #col2) `as` #fromOnly) ) + 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 + ( do + results <- traversePrepared insertAdd [(2::Int32,2::Int32),(3,3),(4,4)] + answers <- traverse firstRow results + liftIO $ print [answer :: Int32 | Just (Only answer) <- answers] + ) + & pqThen (define teardown) +:} +[4,6,8] -} traversePrepared :: ( MonadPQ db pq @@ -207,6 +514,41 @@ {- | `forPrepared` is a flipped `traversePrepared` + +>>> type Column = 'NoDef :=> 'NotNull 'PGint4 +>>> type Columns = '["col1" ::: Column, "col2" ::: Column] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> type DB = Public Schema +>>> import Control.Monad.IO.Class +>>> import Data.Int(Int32) +>>> :{ +let + insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32) + insertAdd = insertInto #tab + ( Values_ $ + Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* + Set (param @2 @('NotNull 'PGint4)) `as` #col2 + ) OnConflictDoRaise + ( Returning_ ((#col1 + #col2) `as` #fromOnly) ) + 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 + ( do + results <- forPrepared [(2::Int32,2::Int32),(3,3),(4,4)] insertAdd + answers <- traverse firstRow results + liftIO $ print [answer :: Int32 | Just (Only answer) <- answers] + ) + & pqThen (define teardown) +:} +[4,6,8] -} forPrepared :: ( MonadPQ db pq @@ -223,10 +565,35 @@ forPrepared = flip traversePrepared {- | -`traversePrepared` runs a returning-free +`traversePrepared_` runs a returning-free `Squeal.PostgreSQL.Manipulation.Manipulation` 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 :: Manipulation_ DB (Int32, Int32) () + insertion = 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 (traversePrepared_ insertion [(2::Int32,2::Int32),(3,3),(4,4)]) + & pqThen (define teardown) +:} -} traversePrepared_ :: ( MonadPQ db pq @@ -241,6 +608,31 @@ {- | `forPrepared_` is a flipped `traversePrepared_` + +>>> 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 :: Manipulation_ DB (Int32, Int32) () + insertion = 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 (forPrepared_ [(2::Int32,2::Int32),(3,3),(4,4)] insertion) + & pqThen (define teardown) +:} -} forPrepared_ :: ( MonadPQ db pq diff --git a/src/Squeal/PostgreSQL/Session/Oid.hs b/src/Squeal/PostgreSQL/Session/Oid.hs --- a/src/Squeal/PostgreSQL/Session/Oid.hs +++ b/src/Squeal/PostgreSQL/Session/Oid.hs @@ -54,7 +54,7 @@ -- | The `LibPQ.Oid` of a `PGType` -- -- >>> :set -XTypeApplications --- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb" +-- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" -- >>> runReaderT (oidOf @'[] @'PGbool) conn -- Oid 16 -- diff --git a/src/Squeal/PostgreSQL/Session/Pool.hs b/src/Squeal/PostgreSQL/Session/Pool.hs --- a/src/Squeal/PostgreSQL/Session/Pool.hs +++ b/src/Squeal/PostgreSQL/Session/Pool.hs @@ -17,11 +17,11 @@ >>> :{ do let - query :: Query_ (Public '[]) () (Only Char) - query = values_ (inline 'a' `as` #fromOnly) - pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10 + qry :: Query_ (Public '[]) () (Only Char) + qry = values_ (inline 'a' `as` #fromOnly) + pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 chr <- usingConnectionPool pool $ do - result <- runQuery query + result <- runQuery qry Just (Only a) <- firstRow result return a destroyConnectionPool pool diff --git a/src/Squeal/PostgreSQL/Session/Result.hs b/src/Squeal/PostgreSQL/Session/Result.hs --- a/src/Squeal/PostgreSQL/Session/Result.hs +++ b/src/Squeal/PostgreSQL/Session/Result.hs @@ -11,6 +11,7 @@ {-# LANGUAGE FlexibleContexts , GADTs + , LambdaCase , OverloadedStrings , ScopedTypeVariables , TypeApplications @@ -22,28 +23,36 @@ , firstRow , getRows , nextRow + , cmdStatus + , cmdTuples , ntuples , nfields , resultStatus , okResult , resultErrorMessage , resultErrorCode + , liftResult ) where import Control.Exception (throw) -import Control.Monad (when) +import Control.Monad (when, (<=<)) 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 +import qualified Data.Text.Encoding as Text import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Generics.SOP as SOP import Squeal.PostgreSQL.Session.Decode import Squeal.PostgreSQL.Session.Exception -{- | `Result`s are generated by running +{- | `Result`s are generated by executing `Squeal.PostgreSQL.Session.Statement`s in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. @@ -138,6 +147,40 @@ 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 @@ -154,10 +197,10 @@ Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage" Just msg -> throw . SQLException $ SQLState status stateCode msg --- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk` +-- | Check if a `Result`'s status is either `LibPQ.CommandOk` -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`. -okResult :: MonadIO io => SOP.K LibPQ.Result row -> io () -okResult = okResult_ . SOP.unK +okResult :: MonadIO io => Result y -> io () +okResult = liftResult okResult_ -- | Returns the error message most recently generated by an operation -- on the connection. diff --git a/src/Squeal/PostgreSQL/Session/Transaction.hs b/src/Squeal/PostgreSQL/Session/Transaction.hs --- a/src/Squeal/PostgreSQL/Session/Transaction.hs +++ b/src/Squeal/PostgreSQL/Session/Transaction.hs @@ -138,7 +138,7 @@ , deferrableMode :: DeferrableMode } deriving (Show, Eq) --- | `TransactionMode` with a `ReadCommited` `IsolationLevel`, +-- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`, -- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`. defaultMode :: TransactionMode defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable diff --git a/src/Squeal/PostgreSQL/Type.hs b/src/Squeal/PostgreSQL/Type.hs --- a/src/Squeal/PostgreSQL/Type.hs +++ b/src/Squeal/PostgreSQL/Type.hs @@ -9,7 +9,6 @@ -} {-# LANGUAGE AllowAmbiguousTypes - , CPP , DeriveAnyClass , DeriveFoldable , DeriveFunctor @@ -61,6 +60,10 @@ {- | The `Money` newtype stores a monetary value in terms of the number of cents, i.e. @$2,000.20@ would be expressed as @Money { cents = 200020 }@. + +>>> :kind! PG Money +PG Money :: PGType += 'PGmoney -} newtype Money = Money { cents :: Int64 } deriving stock (Eq, Ord, Show, Read, GHC.Generic) @@ -69,6 +72,10 @@ {- | The `Json` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGjson`. + +>>> :kind! PG (Json [String]) +PG (Json [String]) :: PGType += 'PGjson -} newtype Json hask = Json {getJson :: hask} deriving stock (Eq, Ord, Show, Read, GHC.Generic) @@ -77,6 +84,10 @@ {- | The `Jsonb` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGjsonb`. + +>>> :kind! PG (Jsonb [String]) +PG (Jsonb [String]) :: PGType += 'PGjsonb -} newtype Jsonb hask = Jsonb {getJsonb :: hask} deriving stock (Eq, Ord, Show, Read, GHC.Generic) @@ -85,6 +96,20 @@ {- | The `Composite` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGcomposite`. + +>>> :{ +data Complex = Complex + { real :: Double + , imaginary :: Double + } deriving stock GHC.Generic + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +:} + +>>> :kind! PG (Composite Complex) +PG (Composite Complex) :: PGType += 'PGcomposite + '["real" ::: 'NotNull 'PGfloat8, + "imaginary" ::: 'NotNull 'PGfloat8] -} newtype Composite record = Composite {getComposite :: record} deriving stock (Eq, Ord, Show, Read, GHC.Generic) @@ -93,6 +118,10 @@ {- | The `Enumerated` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGenum`. + +>>> :kind! PG (Enumerated Ordering) +PG (Enumerated Ordering) :: PGType += 'PGenum '["LT", "EQ", "GT"] -} newtype Enumerated enum = Enumerated {getEnumerated :: enum} deriving stock (Eq, Ord, Show, Read, GHC.Generic) @@ -130,7 +159,12 @@ instance SOP.Generic (Only x) instance SOP.HasDatatypeInfo (Only x) --- | Variable-length text type with limit +{- | Variable-length text type with limit + +>>> :kind! PG (VarChar 4) +PG (VarChar 4) :: PGType += 'PGvarchar 4 +-} newtype VarChar (n :: Nat) = VarChar Strict.Text deriving (Eq,Ord,Read,Show) @@ -145,7 +179,12 @@ getVarChar :: VarChar n -> Strict.Text getVarChar (VarChar t) = t --- | Fixed-length, blank padded +{- | Fixed-length, blank padded + +>>> :kind! PG (FixChar 4) +PG (FixChar 4) :: PGType += 'PGchar 4 +-} newtype FixChar (n :: Nat) = FixChar Strict.Text deriving (Eq,Ord,Read,Show) diff --git a/src/Squeal/PostgreSQL/Type/Alias.hs b/src/Squeal/PostgreSQL/Type/Alias.hs --- a/src/Squeal/PostgreSQL/Type/Alias.hs +++ b/src/Squeal/PostgreSQL/Type/Alias.hs @@ -44,6 +44,7 @@ , mapAliased , Has , HasUnique + , HasErr , HasAll , HasIn -- * Qualified Aliases @@ -183,13 +184,20 @@ -- | @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 + +{- | `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 => - Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) + HasErr err (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) | alias fields -> field where instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1) - => Has alias (alias ::: field0 ': fields) field1 -instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field) - => Has alias (field' ': fields) field + => HasErr err alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr err alias fields field) + => HasErr err alias (field' ': fields) field {-| @HasIn fields (alias ::: field)@ is a constraint that proves that @fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to diff --git a/src/Squeal/PostgreSQL/Type/List.hs b/src/Squeal/PostgreSQL/Type/List.hs --- a/src/Squeal/PostgreSQL/Type/List.hs +++ b/src/Squeal/PostgreSQL/Type/List.hs @@ -91,11 +91,6 @@ type family Elem x xs where Elem x '[] = 'False Elem x (x ': _) = 'True - Elem x (_ ': x ': _) = 'True - Elem x (_ ': _ ': x ': _) = 'True - Elem x (_ ': _ ': _ ': x ': _) = 'True - Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True - Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True Elem x (_ ': xs) = Elem x xs -- | @In x xs@ is a constraint that proves that @x@ is in @xs@. @@ -110,9 +105,5 @@ = 4 -} type family Length (xs :: [k]) :: Nat where - Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs - Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs - Length (_ ': _ ': _ : xs) = 3 + Length xs - Length (_ ': _ : xs) = 2 + Length xs - Length (_ : xs) = 1 + Length xs Length '[] = 0 + Length (_ : xs) = 1 + Length xs diff --git a/src/Squeal/PostgreSQL/Type/PG.hs b/src/Squeal/PostgreSQL/Type/PG.hs --- a/src/Squeal/PostgreSQL/Type/PG.hs +++ b/src/Squeal/PostgreSQL/Type/PG.hs @@ -5,12 +5,11 @@ Maintainer: eitan@morphism.tech Stability: experimental -`Squeal.PostgreSQL.Type.PG` provides type families for turning Haskell -`Type`s into corresponding Postgres types. +Provides type families for turning Haskell `Type`s +into corresponding Postgres types. -} {-# LANGUAGE AllowAmbiguousTypes - , CPP , DeriveAnyClass , DeriveFoldable , DeriveFunctor @@ -275,13 +274,8 @@ -- | Calculates constructors of a datatype. type family ConstructorsOf (datatype :: Type.DatatypeInfo) :: [Type.ConstructorInfo] where -#if MIN_VERSION_generics_sop(0,5,0) ConstructorsOf ('Type.ADT _module _datatype constructors _strictness) = constructors -#else - ConstructorsOf ('Type.ADT _module _datatype constructors) = - constructors -#endif ConstructorsOf ('Type.Newtype _module _datatype constructor) = '[constructor] diff --git a/src/Squeal/PostgreSQL/Type/Schema.hs b/src/Squeal/PostgreSQL/Type/Schema.hs --- a/src/Squeal/PostgreSQL/Type/Schema.hs +++ b/src/Squeal/PostgreSQL/Type/Schema.hs @@ -5,8 +5,8 @@ Maintainer: eitan@morphism.tech Stability: experimental -`Squeal.PostgreSQL.Type.Schema` provides a type-level DSL -for kinds of Postgres types, tables, schema, constraints, and more. +Provides a type-level DSL for kinds of Postgres types, +tables, schema, constraints, and more. It also defines useful type families to operate on these. -} @@ -71,13 +71,13 @@ , AlterIfExists , Rename , RenameIfExists + , SetSchema , ConstraintInvolves , DropIfConstraintsInvolve -- * Type Classification , PGNum , PGIntegral , PGFloating - , PGTypeOf , PGJsonType , PGJsonKey , SamePGType @@ -149,7 +149,7 @@ | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types. | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word. | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for. - | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables. + | PGoid -- ^ Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables. | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype). | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types @@ -210,7 +210,7 @@ = Check [Symbol] | Unique [Symbol] | PrimaryKey [Symbol] - | ForeignKey [Symbol] Symbol [Symbol] + | ForeignKey [Symbol] Symbol Symbol [Symbol] {- | A `TableConstraints` is a row of `TableConstraint`s. @@ -243,7 +243,7 @@ -- :} type TableType = (TableConstraints,ColumnsType) -{- | A `RowType` is a row of `NullType`. They correspond to Haskell +{- | A `RowType` is a row of `NullType`s. They correspond to Haskell record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places. >>> :{ @@ -258,8 +258,8 @@ type RowType = [(Symbol,NullType)] {- | `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.FromClause`s -and `Squeal.PostgreSQL.Query.TableExpression`s. +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)] @@ -287,10 +287,6 @@ -- | Integral Postgres types. type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8] --- | `PGTypeOf` forgets about @NULL@ and any column constraints. -type family PGTypeOf (ty :: NullType) :: PGType where - PGTypeOf (null pg) = pg - -- | Equality constraint on the underlying `PGType` of two columns. class SamePGType (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where @@ -311,8 +307,7 @@ -- | `NullifyType` is an idempotent that nullifies a `NullType`. type family NullifyType (ty :: NullType) :: NullType where - NullifyType ('Null ty) = 'Null ty - NullifyType ('NotNull ty) = 'Null ty + NullifyType (null ty) = 'Null ty -- | `NullifyRow` is an idempotent that nullifies a `RowType`. type family NullifyRow (columns :: RowType) :: RowType where @@ -322,15 +317,15 @@ -- | `NullifyFrom` is an idempotent that nullifies a `FromType` -- used to nullify the left or right hand side of an outer join --- in a `Squeal.PostgreSQL.Query.FromClause`. +-- in a `Squeal.PostgreSQL.Query.From.FromClause`. type family NullifyFrom (tables :: FromType) :: FromType where NullifyFrom (table ::: columns ': tables) = table ::: NullifyRow columns ': NullifyFrom tables NullifyFrom '[] = '[] -- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in --- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@ --- `Squeal.PostgreSQL.Definition.addColumn`. +-- `Squeal.PostgreSQL.Definition.Table.createTable` statements and in @ALTER TABLE@ +-- `Squeal.PostgreSQL.Definition.Table.addColumn`. type family Create alias x xs where Create alias x '[] = '[alias ::: x] Create alias x (alias ::: y ': xs) = TypeError @@ -439,12 +434,18 @@ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs +-- | Move an object from one schema to another +type family SetSchema sch0 sch1 schema0 schema1 obj srt ty db where + SetSchema sch0 sch1 schema0 schema1 obj srt ty db = Alter sch1 + (Create obj (srt ty) schema1) + (Alter sch0 (DropSchemum obj srt schema0) db) + -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where ConstraintInvolves column ('Check columns) = column `Elem` columns ConstraintInvolves column ('Unique columns) = column `Elem` columns ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns - ConstraintInvolves column ('ForeignKey columns tab refcolumns) + ConstraintInvolves column ('ForeignKey columns sch tab refcolumns) = column `Elem` columns -- | Drop all `TableConstraint`s that involve a column @@ -455,7 +456,7 @@ (DropIfConstraintsInvolve column constraints) (alias ::: constraint ': DropIfConstraintsInvolve column constraints) --- | A `SchemumType` is a user-defined type, either a `Table`, +-- | A `SchemumType` is a user-created type, like a `Table`, -- `View` or `Typedef`. data SchemumType = Table TableType @@ -463,10 +464,17 @@ | Typedef PGType | Index IndexType | Function FunctionType + | Procedure [NullType] | UnsafeSchemum Symbol --- | Use `:=>` to pair the parameter types with the return --- type of a function. +{- | Use `:=>` to pair the parameter types with the return +type of a function. + +>>> :{ +type family Fn :: FunctionType where + Fn = '[ 'NotNull 'PGint4] :=> 'Returns ('NotNull 'PGint4) +:} +-} type FunctionType = ([NullType], ReturnsType) {- | @@ -500,7 +508,7 @@ = Returns NullType -- ^ function | ReturnsTable RowType -- ^ set returning function -{- | The schema of a database consists of a list of aliased, +{- | A schema of a database consists of a list of aliased, user-defined `SchemumType`s. >>> :{ @@ -513,7 +521,7 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 @@ -548,12 +556,14 @@ -- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas -- the overloaded label, `fromLabel` is used for column references, -- `label`s are used for enum terms. A `label` is called with --- type application like `label @"beef"`. +-- type application like `label` @"beef". class IsPGlabel (label :: Symbol) expr where label :: expr instance label ~ label1 => IsPGlabel label (PGlabel label1) where label = PGlabel instance labels ~ '[label] => 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 -- | A `PGlabel` unit type with an `IsPGlabel` instance data PGlabel (label :: Symbol) = PGlabel instance KnownSymbol label => RenderSQL (PGlabel label) where diff --git a/test/Property.hs b/test/Property.hs --- a/test/Property.hs +++ b/test/Property.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DataKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , DerivingVia , FlexibleContexts , GADTs , LambdaCase @@ -8,6 +12,7 @@ , ScopedTypeVariables , TypeApplications , TypeOperators + , UndecidableInstances #-} module Main (main) where @@ -22,12 +27,17 @@ import Hedgehog hiding (Range) import Main.Utf8 import Squeal.PostgreSQL hiding (check) +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Main as Main import qualified Hedgehog.Range as Range main :: IO () -main = withUtf8 $ Main.defaultMain [checkSequential roundtrips] +main = withUtf8 $ do + withConnection connectionString $ define createSchwarma + Main.defaultMain [checkSequential roundtrips] + withConnection connectionString $ define dropSchwarma roundtrips :: Group roundtrips = Group "roundtrips" @@ -53,6 +63,8 @@ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime) , roundtrip tstzrange (genRange genUTCTime) , roundtripOn normalizeIntRange daterange (genRange genDay) + , roundtrip (typedef #schwarma) genSchwarma + , roundtrip (vararray (typedef #schwarma)) genSchwarmaArray ] where genInt16 = Gen.int16 Range.exponentialBounded @@ -105,24 +117,26 @@ -- genTimeZone = Gen.element $ map (read @TimeZone) -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST" -- , "CDT", "MST", "MDT", "PST", "PDT" ] + genSchwarma = Gen.enumBounded @_ @Schwarma + genSchwarmaArray = VarArray <$> Gen.list (Range.constant 1 10) genSchwarma roundtrip - :: forall db x - . ( ToPG db x, FromPG x, Inline x - , OidOf db (PG x), PGTyped db (PG x) + :: forall x + . ( ToPG DB x, FromPG x, Inline x + , OidOf DB (PG x), PGTyped DB (PG x) , Show x, Eq x ) - => TypeExpression db ('NotNull (PG x)) + => TypeExpression DB ('NotNull (PG x)) -> Gen x -> (PropertyName, Property) roundtrip = roundtripOn id roundtripOn - :: forall db x - . ( ToPG db x, FromPG x, Inline x - , OidOf db (PG x), PGTyped db (PG x) + :: forall x + . ( ToPG DB x, FromPG x, Inline x + , OidOf DB (PG x), PGTyped DB (PG x) , Show x, Eq x ) => (x -> x) - -> TypeExpression db ('NotNull (PG x)) + -> TypeExpression DB ('NotNull (PG x)) -> Gen x -> (PropertyName, Property) roundtripOn norm ty gen = propertyWithName $ do @@ -156,7 +170,7 @@ x = encodeFloat (b^n - 1) (l - n - 1) connectionString :: ByteString -connectionString = "host=localhost port=5432 dbname=exampledb" +connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int normalizeIntRange = \case @@ -203,3 +217,16 @@ stripped = \case '\NUL' -> "" ch -> [ch] + +data Schwarma = Chicken | Lamb | Beef + deriving stock (Eq, 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)]] + +createSchwarma :: Definition '["public" ::: '[]] DB +createSchwarma = createTypeEnumFrom @Schwarma #schwarma + +dropSchwarma :: Definition DB '["public" ::: '[]] +dropSchwarma = dropType #schwarma diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -59,6 +59,14 @@ insertUser = insertInto_ #users (Values_ (Default `as` #id :* Set (param @1) `as` #name)) +insertUsers :: Text -> [Text] -> Statement DB () () +insertUsers name1 names = manipulation $ insertInto_ #users $ Values + (Default `as` #id :* Set (inline name1) `as` #name) + [Default `as` #id :* Set (inline namei) `as` #name | namei <- names] + +deleteUser :: Text -> Statement DB () () +deleteUser name1 = manipulation $ deleteFrom_ #users (#name .== inline name1) + setup :: Definition (Public '[]) DB setup = createTable #users @@ -71,9 +79,11 @@ teardown :: Definition DB (Public '[]) teardown = dropType #person >>> dropTable #users +silent :: Statement db () () +silent = manipulation $ UnsafeManipulation "Set client_min_messages TO WARNING" + silence :: MonadPQ db pq => pq () -silence = manipulate_ $ - UnsafeManipulation "SET client_min_messages TO WARNING;" +silence = execute_ silent setupDB :: IO () setupDB = withConnection connectionString $ @@ -84,7 +94,7 @@ silence & pqThen (define teardown) connectionString :: ByteString -connectionString = "host=localhost port=5432 dbname=exampledb" +connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" data Person = Person { name :: Maybe String, age :: Maybe Int32 } deriving (Eq, Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo) @@ -115,7 +125,7 @@ it "should manage concurrent transactions" $ do pool <- createConnectionPool - "host=localhost port=5432 dbname=exampledb" 1 0.5 10 + "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 let qry :: Query_ (Public '[]) () (Only Char) qry = values_ (inline 'a' `as` #fromOnly) @@ -210,3 +220,30 @@ out2_array `shouldBe` Just (Only people) unsafe_array `shouldBe` Just (Only (VarArray [Composite adam])) nothings `shouldBe` Just (Only (Person Nothing Nothing)) + + describe "cmdStatus and cmdTuples" $ do + + let + statusAndTuples stmnt = withConnection connectionString $ do + result <- execute stmnt + status <- cmdStatus result + tuples <- cmdTuples result + return (status, tuples) + + it "should tell you about the command and the number of rows effected" $ do + + (status1, tuples1) <- statusAndTuples (insertUsers "Jonah" ["Isaiah"]) + status1 `shouldBe` "INSERT 0 2" + tuples1 `shouldBe` Just 2 + + (status2, tuples2) <- statusAndTuples (deleteUser "Noah") + status2 `shouldBe` "DELETE 0" + tuples2 `shouldBe` Just 0 + + (status3, tuples3) <- statusAndTuples (deleteUser "Jonah") + status3 `shouldBe` "DELETE 1" + tuples3 `shouldBe` Just 1 + + (status4, tuples4) <- statusAndTuples silent + status4 `shouldBe` "SET" + tuples4 `shouldBe` Nothing