diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ # 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) +[![GithubWorkflowCI](https://github.com/morphismtech/squeal/actions/workflows/ci.yml/badge.svg)](https://github.com/morphismtech/squeal/actions/workflows/ci.yml) [Github](https://github.com/morphismtech/squeal) diff --git a/bench/Gauge.hs b/bench/Gauge.hs new file mode 100644 --- /dev/null +++ b/bench/Gauge.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Squeal.PostgreSQL hiding ( defaultMain ) +import Gauge.Main +import Gauge.Main.Options ( defaultConfig + , Config(..) + , Verbosity(..) + , DisplayMode(..) + , Mode(..) + ) +import GHC.Generics +import qualified Generics.SOP as SOP +import Test.QuickCheck +-- For CI +import Main.Utf8 ( withUtf8 ) +-- For keeping a track of which question ID to query +import Data.Int ( Int64 ) +import Data.IORef +-- Project imports +import Gauge.Schema +import Gauge.Queries +import Gauge.DBSetup ( teardownDB ) +import Gauge.DBHelpers ( initDBWithPool + , getRandomUser + , runDbWithPool + , SquealPool + ) + +main :: IO () +main = do + -- A mutable hack here to keep track of + -- pulling a new user by ID from the db instead of the same id + currentId <- newIORef (1 :: UserId) + + -- Define benchmarks + let + queryRenderGroup :: Benchmark + queryRenderGroup = bgroup + "Render Queries" + [ bench "createUser: weak head normal form" $ whnf renderSQL createUser + , bench "createUser: normal form" $ nf renderSQL createUser + , bench "userDetails: weak head normal form" $ whnf renderSQL userDetails + , bench "userDetails: normal form" $ nf renderSQL userDetails + , bench "insertDeviceDetails: weak head normal form" + $ whnf renderSQL insertDeviceDetails + , bench "insertDeviceDetails: normal form" + $ nf renderSQL insertDeviceDetails + ] + + -- Queries against an actual DB + + -- 1. Initialize Schema to DB + -- 2. Make connection pool and pass it to tests + -- 3. Generate users on the fly and add them to DB + -- 4. Tear the Schema down from the DB + + dbInsertsGroup :: Benchmark + dbInsertsGroup = + envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup + "Run individual INSERTs against DB using a connection pool" + [ bgroup + "INSERT: add users to the table users" + [ bench "Run individual INSERT statement" $ makeRunOnce $ perRunEnv + getRandomUser + -- The actual action to benchmark + (\(user :: InsertUser) -> + runDbWithPool pool $ createUserSession user + ) + ] + ] + + dbSelectsGroup :: Benchmark + dbSelectsGroup = + envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup + "Run individual SELECTs against DB using a connection pool" + [ bgroup + "SELECT: fetch users from the table users individually" + [ bench "Fetch a single user" $ makeRunOnce $ perRunEnv + (insertAndIncrement pool currentId) + (\(id_ :: UserId) -> runDbWithPool pool $ userDetailsSession id_ + ) + ] + ] + + withUtf8 $ defaultMain [queryRenderGroup, dbInsertsGroup, dbSelectsGroup] + + +-- | Configure the benchmark to run only once (per IO action) +makeRunOnce :: Benchmarkable -> Benchmarkable +makeRunOnce current = current { perRun = True } + +getAndIncrementId :: (IORef UserId) -> IO UserId +getAndIncrementId currentId = do + current <- readIORef currentId + writeIORef currentId (current + 1) + return current + +-- | This INSERTs a row in the db so that there's always a row to query. +-- Otherwise 'getRow 0' throws an exception. +-- NOTE: will make benchmark time slower but does not affect results. +insertAndIncrement :: SquealPool -> (IORef UserId) -> IO UserId +insertAndIncrement pool currentId = do + user <- getRandomUser + _ <- runDbWithPool pool $ createUserSession user + getAndIncrementId currentId diff --git a/bench/Gauge/DBHelpers.hs b/bench/Gauge/DBHelpers.hs new file mode 100644 --- /dev/null +++ b/bench/Gauge/DBHelpers.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Gauge.DBHelpers where + +import qualified Data.ByteString.Char8 as C +import qualified Data.Text as T +import Control.Monad ( void ) +import Control.Monad.IO.Class ( liftIO ) +import Control.Monad.Loops ( iterateWhile ) +import GHC.Generics ( Generic ) +import Test.QuickCheck +import Squeal.PostgreSQL +import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe +import Control.DeepSeq +-- Project imports +import Gauge.Schema ( Schemas ) +import Gauge.Queries ( InsertUser(..) ) +import Gauge.DBSetup + +newtype SquealPool = SquealPool {getSquealPool :: Pool (K Connection Schemas)} deriving (Generic) +-- Below may be wrong - it may screw up the whole connection pool using in tests +instance NFData SquealPool where + rnf = rwhnf + +runDbErr + :: SquealPool -> PQ Schemas Schemas IO b -> IO (Either SquealException b) +runDbErr pool session = do + liftIO . runUsingConnPool pool $ trySqueal (Unsafe.transactionally_ session) + +runDbWithPool :: SquealPool -> PQ Schemas Schemas IO b -> IO b +runDbWithPool pool session = do + errOrResult <- runDbErr pool session + case errOrResult of + Left err -> throwSqueal err + Right result -> return result + +-- | Helper +runUsingConnPool :: SquealPool -> PQ Schemas Schemas IO x -> IO x +runUsingConnPool (SquealPool pool) = usingConnectionPool pool + +makePool :: C.ByteString -> IO SquealPool +makePool connStr = do + pool <- createConnectionPool connStr 1 0.5 10 + return $ SquealPool pool + +initDBWithPool :: IO SquealPool +initDBWithPool = do + void initDB + pool <- makePool connectionString + return pool + +getRandomUser :: IO InsertUser +getRandomUser = iterateWhile noEmptyEmail $ generate arbitrary + where + noEmptyEmail InsertUser { userEmail = userEmail } = T.length userEmail < 5 diff --git a/bench/Gauge/DBSetup.hs b/bench/Gauge/DBSetup.hs new file mode 100644 --- /dev/null +++ b/bench/Gauge/DBSetup.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Gauge.DBSetup where + +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Char8 as C +import Control.Monad ( void ) +import GHC.Generics +import Squeal.PostgreSQL +-- Project imports +import Gauge.Schema ( Schemas + , DeviceOS + , IPLocation + ) + + +-- First create enums as they're needed in the Schema +setup :: Definition (Public '[]) Schemas +setup = + createTypeEnumFrom @DeviceOS #device_os + >>> createTypeCompositeFrom @IPLocation #ip_location + >>> createTable + #users + ( serial8 + `as` #id + :* (text & notNullable) + `as` #email + :* (text & notNullable) + `as` #password + :* (text & nullable) + `as` #first_name + :* (int2 & nullable) + `as` #birthyear + ) + (primaryKey #id `as` #pk_users :* unique #email `as` #email) + >>> createTable + #user_devices + ( serial8 + `as` #id + :* notNullable int8 + `as` #user_id + :* (text & notNullable) + `as` #token + :* (typedef #device_os & notNullable) + `as` #os + ) + ( primaryKey #id + `as` #pk_user_devices + :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade) + `as` #fk_user_id + :* unique #token + `as` #token + ) + +-- Drop types last because tables depend on them +teardown :: Definition Schemas (Public '[]) +teardown = + dropTableCascade #user_devices + >>> dropTableCascade #users + >>> dropType #ip_location + >>> dropType #device_os + +-- With env vars, we could use the commented keys +data PGConfig = PGConfig + { pgHost :: String -- "PG_HOST" + , pgPort :: Int -- "PG_PORT" + , pgDbname :: String -- "PG_DBNAME" + , pgUser :: String -- "PG_USER" + , pgPassword :: String -- "PG_PASSWORD" + } + deriving (Generic, Show) + +-- | Helper: unused now, but primarily for testing locally +makeConnStr :: PGConfig -> ByteString +makeConnStr PGConfig { pgHost = host, pgPort = portNumber, pgDbname = dbName, pgUser = user, pgPassword = pw } + = C.pack + $ "host=" + <> host + <> " dbname=" + <> dbName + <> " user=" + <> user + <> " password=" + <> pw + <> " port=" + <> show portNumber + +connectionString :: ByteString +connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" + +performDBAction :: Definition a b -> String -> IO () +performDBAction action message = do + void + $ withConnection connectionString + $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;") + & pqThen (define action) + putStrLn message + +initDB :: IO () +initDB = + performDBAction setup "Initialized Schema & corresponding tables for Database" + +teardownDB :: IO () +teardownDB = performDBAction teardown "Dropped all database tables" + +dbSchema :: Definition '["public" ::: '[]] (Drop "public" '["public" ::: '[]]) +dbSchema = dropSchemaCascade #public + +dropDBSchema :: IO () +dropDBSchema = performDBAction dbSchema "Dropped Public schema from database" + +-- | Concatenate two `ByteString`s with a space between. +(<+>) :: ByteString -> ByteString -> ByteString +infixr 7 <+> +str1 <+> str2 = str1 <> " " <> str2 + +-- | Drop table custom SQL statement with 'cascade' +dropTableCascade + :: (Has sch schemas schema, Has tab schema ( 'Table table)) + => QualifiedAlias sch tab -- ^ table to remove + -> Definition schemas (Alter sch (Drop tab schema) schemas) +dropTableCascade tab = + UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> " cascade;" diff --git a/bench/Gauge/Queries.hs b/bench/Gauge/Queries.hs new file mode 100644 --- /dev/null +++ b/bench/Gauge/Queries.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +module Gauge.Queries where + +import Squeal.PostgreSQL +import GHC.Generics ( Generic ) +import qualified Generics.SOP as SOP +-- Need below for deriving instances +import Control.DeepSeq +import Data.Text ( Text ) +import Data.Int ( Int16 + , Int64 + ) +import Test.QuickCheck ( Arbitrary(..) ) +import Generic.Random ( genericArbitrarySingle ) +-- Import Orphan instances +import Test.QuickCheck.Instances ( ) +-- Project imports +import Gauge.Schema + +-- Types + +type UserId = Int64 +-- Insert user +data InsertUser = InsertUser + { userEmail :: Text + , userPassword :: Text + , userFirstName :: Maybe Text + , userBirthyear :: Maybe Int16 + } + deriving (Show, Eq, Generic, NFData) +instance SOP.Generic InsertUser +instance SOP.HasDatatypeInfo InsertUser +-- Arbitrary instances for producing values with quickcheck +instance Arbitrary InsertUser where + arbitrary = genericArbitrarySingle + +sampleInsertUser :: InsertUser +sampleInsertUser = InsertUser { userEmail = "mark@gmail.com" + , userPassword = "MySecretPassword" + , userFirstName = Just "Mark" + , userBirthyear = Just 1980 + } + +data APIDBUser_ = APIDBUser_ + { userId :: UserId + , email :: Text + , first_name :: Maybe Text + , birthyear :: Maybe Int16 + } + deriving (Show, Eq, Generic, NFData) +instance SOP.Generic APIDBUser_ +instance SOP.HasDatatypeInfo APIDBUser_ +-- Arbitrary instances for producing values with quickcheck +instance Arbitrary APIDBUser_ where + arbitrary = genericArbitrarySingle + +data Row3 a b c = Row4 + { col1 :: a + , col2 :: b + , col3 :: c + } + deriving stock Generic + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +-- (UserId, Token, OS) +type DeviceDetailsRow = Row3 UserId Text (Enumerated DeviceOS) + +-- -- Queries + +createUserSession :: InsertUser -> PQ Schemas Schemas IO APIDBUser_ +createUserSession insertUser = + getRow 0 =<< manipulateParams createUser insertUser + +createUser :: Manipulation_ Schemas InsertUser APIDBUser_ +createUser = insertInto + #users + (Values_ + ( Default + `as` #id + :* Set (param @1) + `as` #email + :* Set (param @2) + `as` #password + :* Set (param @3) + `as` #first_name + :* Set (param @4 & cast int2) + `as` #birthyear + ) + ) + OnConflictDoRaise + (Returning_ + ( #id + `as` #userId + :* #email + `as` #email + :* #first_name + `as` #first_name + :* #birthyear + `as` #birthyear + ) + ) + +userDetailsSession :: UserId -> PQ Schemas Schemas IO APIDBUser_ +userDetailsSession uID = getRow 0 =<< runQueryParams userDetails (Only uID) + +userDetails :: Query_ Schemas (Only UserId) APIDBUser_ +userDetails = select_ + ( #id + `as` #userId + :* #email + `as` #email + :* #first_name + `as` #first_name + :* #birthyear + `as` #birthyear + ) + (from (table #users) & where_ (#id .== (param @1 & cast int8))) + +insertDeviceDetails :: Manipulation_ Schemas DeviceDetailsRow () +insertDeviceDetails = insertInto + #user_devices + (Values_ + ( Default + `as` #id + :* Set (param @1) + `as` #user_id + :* Set (param @2) + `as` #token + :* Set (parameter @3 (typedef #device_os)) + `as` #os + ) + ) + OnConflictDoRaise + (Returning_ Nil) diff --git a/bench/Gauge/Schema.hs b/bench/Gauge/Schema.hs new file mode 100644 --- /dev/null +++ b/bench/Gauge/Schema.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} + +module Gauge.Schema where + +import Squeal.PostgreSQL +import GHC.Generics +import qualified Generics.SOP as SOP + + +-- Type + +data DeviceOS = Android | IOS + deriving (Show, Read, Eq, Generic) +-- DeviceOS is converted to PG Enum type +instance SOP.Generic DeviceOS +instance SOP.HasDatatypeInfo DeviceOS + +-- Defined extra types for the database +-- Operating system enum +type PGDeviceOS = PG (Enumerated DeviceOS) +type DeviceOSType = 'Typedef PGDeviceOS + +-- For composite type +data IPLocation = IPLocation + { countryShort :: String + , region :: String + , city :: String + } + deriving (Show, Read, Eq, Generic) + +instance SOP.Generic IPLocation +instance SOP.HasDatatypeInfo IPLocation + +-- IPLocation Composite type +type PGIPLocation = PG (Composite IPLocation) +type IPLocationType = 'Typedef PGIPLocation + +-- SCHEMA + +-- Users + +type UsersColumns = '[ + "id" ::: 'Def :=> 'NotNull 'PGint8 + , "email" ::: 'NoDef :=> 'NotNull 'PGtext + , "password" ::: 'NoDef :=> 'NotNull 'PGtext + , "first_name" ::: 'NoDef :=> 'Null 'PGtext + , "birthyear" ::: 'NoDef :=> 'Null 'PGint2 + ] + +type UsersConstraints = '[ + "pk_users" ::: 'PrimaryKey '["id"] + , "email" ::: 'Unique '["email"] + ] + +type UsersTable = 'Table (UsersConstraints :=> UsersColumns) + +-- User devices +type UserDevicesColumns = '[ + "id" ::: 'Def :=> 'NotNull 'PGint8 -- ID as PK because user might have many same OS devices + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint8 + , "token" ::: 'NoDef :=> 'NotNull 'PGtext + , "os" ::: 'NoDef :=> 'NotNull PGDeviceOS + ] + +type UserDevicesConstraints = '[ + "pk_user_devices" ::: 'PrimaryKey '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + , "token" ::: 'Unique '["token"] + ] + +type UserDevicesTable = 'Table (UserDevicesConstraints :=> UserDevicesColumns) + +-- Schema +-- Make sure to put types before tables, otherwise won't compile +type Schema = '[ + -- Enum types: + "device_os" ::: DeviceOSType + -- Composite types: + , "ip_location" ::: IPLocationType + -- Tables: + , "users" ::: UsersTable + , "user_devices" ::: UserDevicesTable + ] + +type Schemas = '["public" ::: Schema] diff --git a/exe/Example.hs b/exe/Example.hs --- a/exe/Example.hs +++ b/exe/Example.hs @@ -9,11 +9,17 @@ , TypeOperators #-} -module Main (main, main2) where +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main (main, main2, upsertUser) where + +import Control.Monad.Except (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32) -import Data.Monoid ((<>)) import Data.Text (Text) import Data.Vector (Vector) @@ -23,7 +29,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 @@ -32,7 +38,7 @@ ]) , "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 @@ -40,83 +46,239 @@ ]) ] -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 + , "type" ::: '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 :* - (int & notNullable) `as` #user_id :* - (text & nullable) `as` #email ) + 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 ) + foreignKey #user_id (#user ! #users) #id + (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) + >>> + createTable (#org ! #organizations) + ( serial `as` #id :* + (text & notNullable) `as` #name :* + (text & notNullable) `as` #type ) + ( 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 = 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)) +insertOrganization :: Manipulation_ Schemas (Text, OrganizationType) (Only Int32) +insertOrganization = insertInto (#org ! #organizations) + (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #type)) + (OnConflict (OnConstraint #pk_organizations) DoNothing) (Returning_ (#id `as` #fromOnly)) + getUsers :: Query_ Schemas () User getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec) - ( 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)) ) -data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) } - deriving (Show, GHC.Generic) +getOrganizations :: Query_ Schemas () Organization +getOrganizations = select_ + ( #o ! #id `as` #orgId :* + #o ! #name `as` #orgName :* + #o ! #type `as` #orgType + ) + (from (table (#org ! #organizations `as` #o))) + +getOrganizationsBy :: + forall hsty. + (ToPG Schemas hsty) => + Condition + 'Ungrouped + '[] + '[] + Schemas + '[NullPG hsty] + '["o" ::: ["id" ::: NotNull PGint4, "name" ::: NotNull PGtext, "type" ::: NotNull PGtext]] -> + Query_ Schemas (Only hsty) Organization +getOrganizationsBy condition = + select_ + ( #o ! #id `as` #orgId :* + #o ! #name `as` #orgName :* + #o ! #type `as` #orgType + ) + ( + from (table (#org ! #organizations `as` #o)) + & where_ condition + ) + +upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) () +upsertUser = insertInto (#user ! #users `as` #u) + (Values_ (Set (param @1) `as` #id :* setUser)) + (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 + , userEmail :: Maybe Text + , userVec :: VarArray (Vector (Maybe Int16)) + } deriving (Show, GHC.Generic) instance SOP.Generic User instance SOP.HasDatatypeInfo User users :: [User] users = - [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1]) - , User "Bob" Nothing (VarArray [Just 2, Nothing]) - , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3]) + [ User "Alice" (Just "alice@gmail.com") (VarArray [Just 1,Just 2,Nothing]) + , User "Bob" Nothing (VarArray [Nothing,Just (-3)]) + , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3,Nothing, Just 4]) ] +data Organization + = Organization + { orgId :: Int32 + , orgName :: Text + , orgType :: OrganizationType + } deriving (Show, GHC.Generic) +instance SOP.Generic Organization +instance SOP.HasDatatypeInfo Organization + +data OrganizationType + = ForProfit + | NonProfit + deriving (Show, GHC.Generic) +instance SOP.Generic OrganizationType +instance SOP.HasDatatypeInfo OrganizationType + +instance IsPG OrganizationType where + type PG OrganizationType = 'PGtext +instance ToPG db OrganizationType where + toPG = toPG . toText + where + toText ForProfit = "for-profit" :: Text + toText NonProfit = "non-profit" :: Text + +instance FromPG OrganizationType where + fromPG = do + value <- fromPG @Text + fromText value + where + fromText "for-profit" = pure ForProfit + fromText "non-profit" = pure NonProfit + fromText value = throwError $ "Invalid organization type: \"" <> value <> "\"" + +organizations :: [Organization] +organizations = + [ Organization { orgId = 1, orgName = "ACME", orgType = ForProfit } + , Organization { orgId = 2, orgName = "Haskell Foundation", orgType = NonProfit } + ] + session :: (MonadIO pq, MonadPQ Schemas pq) => pq () session = do - liftIO $ Char8.putStrLn "manipulating" - idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users]) - ids <- traverse (fmap fromOnly . getRow 0) idResults - traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) - liftIO $ Char8.putStrLn "querying" + liftIO $ Char8.putStrLn "===> manipulating" + userIdResults <- traversePrepared insertUser [(userName user, userVec user) | user <- users] + userIds <- traverse (fmap fromOnly . getRow 0) (userIdResults :: [Result (Only Int32)]) + traversePrepared_ insertEmail (zip (userIds :: [Int32]) (userEmail <$> users)) + + orgIdResults <- traversePrepared + insertOrganization + [(orgName organization, orgType organization) | organization <- organizations] + _ <- traverse (fmap fromOnly . getRow 0) (orgIdResults :: [Result (Only Int32)]) + + liftIO $ Char8.putStrLn "===> querying: users" usersResult <- runQuery getUsers usersRows <- getRows usersResult liftIO $ print (usersRows :: [User]) + liftIO $ Char8.putStrLn "===> querying: organizations: all" + organizationsResult1 <- runQuery getOrganizations + organizationRows1 <- getRows organizationsResult1 + liftIO $ print (organizationRows1 :: [Organization]) + + liftIO $ Char8.putStrLn "===> querying: organizations: by ID (2)" + organizationsResult2 <- runQueryParams + (getOrganizationsBy @Int32 ((#o ! #id) .== param @1)) (Only (2 :: Int32)) + organizationRows2 <- getRows organizationsResult2 + liftIO $ print (organizationRows2 :: [Organization]) + + liftIO $ Char8.putStrLn "===> querying: organizations: by name (ACME)" + organizationsResult3 <- runQueryParams + (getOrganizationsBy @Text ((#o ! #name) .== param @1)) (Only ("ACME" :: Text)) + organizationRows3 <- getRows organizationsResult3 + liftIO $ print (organizationRows3 :: [Organization]) + + liftIO $ Char8.putStrLn "===> querying: organizations: by type (non-profit)" + organizationsResult4 <- runQueryParams + (getOrganizationsBy @Text ((#o ! #type) .== param @1)) (Only NonProfit) + organizationRows4 <- getRows organizationsResult4 + liftIO $ print (organizationRows4 :: [Organization]) + main :: IO () main = do - Char8.putStrLn "squeal" + Char8.putStrLn "===> squeal" connectionString <- pure - "host=localhost port=5432 dbname=exampledb" + "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Char8.putStrLn $ "connecting to " <> connectionString connection0 <- connectdb connectionString - Char8.putStrLn "setting up schema" + + Char8.putStrLn "===> setting up schema" connection1 <- execPQ (define setup) connection0 connection2 <- execPQ session connection1 - Char8.putStrLn "tearing down schema" + + Char8.putStrLn "===> tearing down schema" connection3 <- execPQ (define teardown) connection2 finish connection3 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,17 +1,17 @@ +cabal-version: 2.2 name: squeal-postgresql -version: 0.5.2.0 +version: 0.9.2.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal bug-reports: https://github.com/morphismtech/squeal/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Eitan Chatav maintainer: eitan.chatav@gmail.com -copyright: Copyright (c) 2017 Morphism, LLC +copyright: Copyright (c) 2022 Morphism, LLC category: Database build-type: Simple -cabal-version: >=1.18 extra-doc-files: README.md source-repository head @@ -22,20 +22,29 @@ hs-source-dirs: src exposed-modules: Squeal.PostgreSQL - Squeal.PostgreSQL.Alias - Squeal.PostgreSQL.Binary 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 Squeal.PostgreSQL.Expression.Aggregate - Squeal.PostgreSQL.Expression.Collection + Squeal.PostgreSQL.Expression.Array Squeal.PostgreSQL.Expression.Comparison + Squeal.PostgreSQL.Expression.Composite + Squeal.PostgreSQL.Expression.Default Squeal.PostgreSQL.Expression.Json - Squeal.PostgreSQL.Expression.Literal + Squeal.PostgreSQL.Expression.Inline Squeal.PostgreSQL.Expression.Logic Squeal.PostgreSQL.Expression.Math Squeal.PostgreSQL.Expression.Null Squeal.PostgreSQL.Expression.Parameter - Squeal.PostgreSQL.Expression.SetOf + Squeal.PostgreSQL.Expression.Range Squeal.PostgreSQL.Expression.Sort Squeal.PostgreSQL.Expression.Subquery Squeal.PostgreSQL.Expression.Text @@ -43,81 +52,161 @@ Squeal.PostgreSQL.Expression.Time Squeal.PostgreSQL.Expression.Type Squeal.PostgreSQL.Expression.Window - Squeal.PostgreSQL.List Squeal.PostgreSQL.Manipulation - Squeal.PostgreSQL.Migration - Squeal.PostgreSQL.Pool - Squeal.PostgreSQL.PG - Squeal.PostgreSQL.PQ + Squeal.PostgreSQL.Manipulation.Call + Squeal.PostgreSQL.Manipulation.Delete + Squeal.PostgreSQL.Manipulation.Insert + Squeal.PostgreSQL.Manipulation.Update Squeal.PostgreSQL.Render Squeal.PostgreSQL.Query - Squeal.PostgreSQL.Schema - Squeal.PostgreSQL.Transaction + Squeal.PostgreSQL.Query.From + Squeal.PostgreSQL.Query.From.Join + Squeal.PostgreSQL.Query.From.Set + Squeal.PostgreSQL.Query.Select + Squeal.PostgreSQL.Query.Table + Squeal.PostgreSQL.Query.Values + Squeal.PostgreSQL.Query.With + Squeal.PostgreSQL.Session + Squeal.PostgreSQL.Session.Connection + Squeal.PostgreSQL.Session.Decode + Squeal.PostgreSQL.Session.Encode + Squeal.PostgreSQL.Session.Exception + Squeal.PostgreSQL.Session.Indexed + Squeal.PostgreSQL.Session.Migration + Squeal.PostgreSQL.Session.Monad + Squeal.PostgreSQL.Session.Oid + Squeal.PostgreSQL.Session.Pool + Squeal.PostgreSQL.Session.Result + Squeal.PostgreSQL.Session.Statement + Squeal.PostgreSQL.Session.Transaction + Squeal.PostgreSQL.Session.Transaction.Unsafe + Squeal.PostgreSQL.Type + Squeal.PostgreSQL.Type.Alias + Squeal.PostgreSQL.Type.List + Squeal.PostgreSQL.Type.PG + Squeal.PostgreSQL.Type.Schema default-language: Haskell2010 ghc-options: -Wall build-depends: - aeson >= 1.2.4.0 - , base >= 4.11.1.0 && < 5.0 + aeson >= 1.4.7.1 + , base >= 4.12.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 - , generics-sop >= 0.3.2.0 && < 0.5.0.0 - , mmorph >= 1.1.1 + , 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.5.1.0 + , hashable >= 1.3.0.0 + , iproute >= 1.7.0 + , mmorph >= 1.1.3 + , monad-control >= 1.0.2.3 , mtl >= 2.2.2 - , network-ip >= 0.3.0.2 - , postgresql-binary >= 0.12.1 - , postgresql-libpq >= 0.9.4.1 - , 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 , uuid-types >= 1.0.3 - , vector >= 0.12.0.1 + , vector >= 0.12.1.2 -test-suite squeal-postgresql-doctest +test-suite doctest default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test ghc-options: -Wall - main-is: DocTest.hs + main-is: Doc.hs build-depends: - base >= 4.10.0.0 - , doctest >= 0.11.4 + base >= 4.12.0.0 && < 5.0 + , doctest >= 0.16.3 + if impl(ghc >= 9.0.0) + buildable: False -test-suite squeal-postgresql-specs +test-suite properties default-language: Haskell2010 type: exitcode-stdio-1.0 - hs-source-dirs: test/Specs + hs-source-dirs: test + ghc-options: -Wall + main-is: Property.hs + build-depends: + base >= 4.12.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.6.2 + , squeal-postgresql + , time >= 1.9.3 + , with-utf8 >= 1.0 + +test-suite spec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test ghc-options: -Wall - main-is: Specs.hs - other-modules: ExceptionHandling + main-is: Spec.hs build-depends: - base >= 4.10.0.0 - , async >= 2.2.2 - , bytestring >= 0.10.8.2 - , generics-sop >= 0.3.1.0 - , hspec >= 2.4.8 + async >= 2.2.2 + , base >= 4.12.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 - , transformers >= 0.5.2.0 - , vector >= 0.12.0.1 + , text >= 1.2.3.2 + , vector >= 0.12.1.2 -executable squeal-postgresql-example +benchmark gauge + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Gauge.hs + other-modules: + Gauge.DBHelpers + , Gauge.DBSetup + , Gauge.Queries + , Gauge.Schema default-language: Haskell2010 + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + -rtsopts + -funbox-strict-fields + build-depends: + base >= 4.12.0.0 && < 5.0 + , bytestring >= 0.10.10.0 + , deepseq >= 1.4.4.0 + , gauge >= 0.2.5 + , 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.6.2 + , squeal-postgresql + , text >= 1.2.3.2 + , with-utf8 >= 1.0 + +executable example + default-language: Haskell2010 hs-source-dirs: exe ghc-options: -Wall 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 @@ -1,6 +1,6 @@ {-| Module: Squeal.PostgreSQL -Description: Squeal export module +Description: export module Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental @@ -40,11 +40,11 @@ , "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) ] -type Schemas = Public Schema +type DB = Public Schema :} Notice the use of type operators. @@ -54,7 +54,7 @@ operator. `:=>` is used to pair `TableConstraints` with a `ColumnsType`, -yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, +yielding a `TableType`, or to pair an `Optionality` with a `NullType`, yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator Next, we'll write `Definition`s to set up and tear down the schema. In @@ -66,7 +66,7 @@ >>> :{ let - setup :: Definition (Public '[]) Schemas + setup :: Definition (Public '[]) DB setup = createTable #users ( serial `as` #id :* @@ -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. @@ -87,14 +87,14 @@ CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); -Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@. +Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @DB@. In our `createTable` commands we included `TableConstraint`s to define primary and foreign keys, making them somewhat complex. Our @teardown@ `Definition` is simpler. >>> :{ let - teardown :: Definition Schemas (Public '[]) + teardown :: Definition DB (Public '[]) teardown = dropTable #emails >>> dropTable #users :} @@ -105,25 +105,27 @@ We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and `Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s. ->>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) ->>> instance SOP.Generic User ->>> instance SOP.HasDatatypeInfo User +>>> :set -XDerivingStrategies -XDeriveAnyClass +>>> :{ +data User = User { userName :: Text, userEmail :: Maybe Text } + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +:} -Next, we'll write `Manipulation_`s to insert @User@s into our two tables. -A `Manipulation_` like `insertInto`, `update` or `deleteFrom` -has three type parameters, the schemas it refers to, input parameters -and an output row. When +Next, we'll write `Statement`s to insert @User@s into our two tables. +A `Statement` has three type parameters, the schemas it refers to, +input parameters and an output row. When we insert into the users table, we will need a parameter for the @name@ field but not for the @id@ field. Since it's serial, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into -the emails table. We can do this in a single `Manipulation_` by using a -`with` statement. +the emails table. We can do this in a single `Statement` by using a +`with` `manipulation`. >>> :{ let - insertUser :: Manipulation_ Schemas User () - insertUser = with (u `as` #u) e + insertUser :: Statement DB User () + insertUser = manipulation $ with (u `as` #u) e where u = insertInto #users (Values_ (Default `as` #id :* Set (param @1) `as` #name)) @@ -134,17 +136,16 @@ :} >>> 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 `Query_` to retrieve users from the database. We're not +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 -need to use an `innerJoin` to get the right result. A `Query_` is like a -`Manipulation_` with the same kind of type parameters. +need to use an `innerJoin` to get the right result. >>> :{ let - getUsers :: Query_ Schemas () User - getUsers = select_ + getUsers :: Statement DB () User + getUsers = query $ select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail) ( from (table (#users `as` #u) & innerJoin (table (#emails `as` #e)) @@ -176,36 +177,54 @@ >>> :{ let - session :: PQ Schemas Schemas IO () + session :: PQ DB DB IO () session = do - _ <- traversePrepared_ insertUser users - usersResult <- runQuery getUsers + executePrepared_ insertUser users + usersResult <- execute getUsers usersRows <- getRows usersResult - liftIO $ print (usersRows :: [User]) + 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) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] + +This should get you up and running with Squeal. Once you're writing more complicated +queries and need a deeper understanding of Squeal's types and how everything +fits together, check out the +in the toplevel of Squeal's Git repo. -} -module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where +module Squeal.PostgreSQL + ( module X + , RenderSQL (..) + , printSQL + ) where -import Squeal.PostgreSQL.Alias as X -import Squeal.PostgreSQL.Binary as X 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 +import Squeal.PostgreSQL.Definition.View as X import Squeal.PostgreSQL.Expression as X import Squeal.PostgreSQL.Expression.Aggregate as X -import Squeal.PostgreSQL.Expression.Collection as X +import Squeal.PostgreSQL.Expression.Array as X import Squeal.PostgreSQL.Expression.Comparison as X +import Squeal.PostgreSQL.Expression.Composite as X +import Squeal.PostgreSQL.Expression.Default as X import Squeal.PostgreSQL.Expression.Json as X -import Squeal.PostgreSQL.Expression.Literal as X +import Squeal.PostgreSQL.Expression.Inline as X import Squeal.PostgreSQL.Expression.Logic as X import Squeal.PostgreSQL.Expression.Math as X import Squeal.PostgreSQL.Expression.Null as X import Squeal.PostgreSQL.Expression.Parameter as X -import Squeal.PostgreSQL.Expression.SetOf as X +import Squeal.PostgreSQL.Expression.Range as X import Squeal.PostgreSQL.Expression.Sort as X import Squeal.PostgreSQL.Expression.Subquery as X import Squeal.PostgreSQL.Expression.Text as X @@ -213,13 +232,35 @@ import Squeal.PostgreSQL.Expression.Time as X import Squeal.PostgreSQL.Expression.Type as X import Squeal.PostgreSQL.Expression.Window as X -import Squeal.PostgreSQL.List as X import Squeal.PostgreSQL.Manipulation as X -import Squeal.PostgreSQL.Migration as X -import Squeal.PostgreSQL.PG as X -import Squeal.PostgreSQL.Pool as X -import Squeal.PostgreSQL.PQ 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 import Squeal.PostgreSQL.Query as X +import Squeal.PostgreSQL.Query.From as X +import Squeal.PostgreSQL.Query.From.Join as X +import Squeal.PostgreSQL.Query.From.Set as X +import Squeal.PostgreSQL.Query.Select as X +import Squeal.PostgreSQL.Query.Table as X +import Squeal.PostgreSQL.Query.Values as X +import Squeal.PostgreSQL.Query.With as X import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL) -import Squeal.PostgreSQL.Schema as X -import Squeal.PostgreSQL.Transaction as X +import Squeal.PostgreSQL.Session as X +import Squeal.PostgreSQL.Session.Connection as X +import Squeal.PostgreSQL.Session.Decode as X +import Squeal.PostgreSQL.Session.Encode as X +import Squeal.PostgreSQL.Session.Exception as X +import Squeal.PostgreSQL.Session.Indexed as X +import Squeal.PostgreSQL.Session.Migration as X +import Squeal.PostgreSQL.Session.Monad as X +import Squeal.PostgreSQL.Session.Oid as X +import Squeal.PostgreSQL.Session.Pool as X +import Squeal.PostgreSQL.Session.Result as X +import Squeal.PostgreSQL.Session.Statement as X +import Squeal.PostgreSQL.Session.Transaction as X +import Squeal.PostgreSQL.Type as X +import Squeal.PostgreSQL.Type.Alias as X +import Squeal.PostgreSQL.Type.List as X +import Squeal.PostgreSQL.Type.PG as X +import Squeal.PostgreSQL.Type.Schema as X diff --git a/src/Squeal/PostgreSQL/Alias.hs b/src/Squeal/PostgreSQL/Alias.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Alias.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Alias -Description: Aliases -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module embeds Postgres's alias system in Haskell in -a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension, -Squeal can reference aliases by prepending with a @#@. --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , OverloadedStrings - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilyDependencies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Alias - ( (:::) - , Alias (..) - , IsLabel (..) - , Aliased (As) - , Aliasable (as) - , renderAliased - , Has - , HasUnique - , HasAll - , HasIn - , QualifiedAlias (..) - , IsQualified (..) - -- * Grouping - , Grouping (..) - , GroupedBy - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) -import Data.String (fromString) -import GHC.OverloadedLabels -import GHC.TypeLits - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Render - --- $setup --- >>> import Squeal.PostgreSQL - --- | The alias operator `:::` is like a promoted version of `As`, --- a type level pair between an alias and some type. -type (:::) (alias :: Symbol) ty = '(alias,ty) -infixr 6 ::: - - --- | `Grouping` is an auxiliary namespace, created by --- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used --- for typesafe aggregation -data Grouping - = Ungrouped -- ^ no aggregation permitted - | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped - -{- | A `GroupedBy` constraint indicates that a table qualified column is -a member of the auxiliary namespace created by @GROUP BY@ clauses and thus, -may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating. --} -class (KnownSymbol table, KnownSymbol column) - => GroupedBy table column bys where -instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column) - => GroupedBy table column ('(table,column) ': bys) -instance {-# OVERLAPPABLE #-} - ( KnownSymbol table - , KnownSymbol column - , GroupedBy table column bys - ) => GroupedBy table column (tabcol ': bys) - --- | `Alias`es are proxies for a type level string or `Symbol` --- and have an `IsLabel` instance so that with @-XOverloadedLabels@ --- --- >>> :set -XOverloadedLabels --- >>> #foobar :: Alias "foobar" --- Alias -data Alias (alias :: Symbol) = Alias - deriving (Eq,GHC.Generic,Ord,Show,NFData) -instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where - fromLabel = Alias -instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where - fromLabel = fromLabel SOP.:* Nil --- | >>> printSQL (#jimbob :: Alias "jimbob") --- "jimbob" -instance KnownSymbol alias => RenderSQL (Alias alias) where - renderSQL = doubleQuoted . fromString . symbolVal - --- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"]) --- "jimbob", "kandi" -instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where - renderSQL - = commaSeparated - . SOP.hcollapse - . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL) - --- | The `As` operator is used to name an expression. `As` is like a demoted --- version of `:::`. --- --- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String) --- As (Just "hello") Alias -data Aliased expression aliased where - As - :: KnownSymbol alias - => expression ty - -> Alias alias - -> Aliased expression (alias ::: ty) -deriving instance Show (expression ty) - => Show (Aliased expression (alias ::: ty)) -deriving instance Eq (expression ty) - => Eq (Aliased expression (alias ::: ty)) -deriving instance Ord (expression ty) - => Ord (Aliased expression (alias ::: ty)) -instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2) - => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where - fromLabel = fromLabel @alias2 `As` fromLabel @alias1 - --- | The `Aliasable` class provides a way to scrap your `Nil`s --- in an `NP` list of `Aliased` expressions. -class KnownSymbol alias => Aliasable alias expression aliased - | aliased -> expression - , aliased -> alias - where as :: expression -> Alias alias -> aliased -instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias - (expression ty) - (Aliased expression aliased) - where - as = As -instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias - (expression ty) - (NP (Aliased expression) tys) - where - expression `as` alias = expression `As` alias SOP.:* Nil - --- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just") --- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int) --- "Just AS \"an_int\"" -renderAliased - :: (forall ty. expression ty -> ByteString) - -> Aliased expression aliased - -> ByteString -renderAliased render (expression `As` alias) = - render expression <> " AS " <> renderSQL alias - --- | @HasUnique alias fields field@ is a constraint that proves that --- @fields@ is a singleton of @alias ::: field@. -type HasUnique alias fields field = fields ~ '[alias ::: field] - --- | @Has alias fields field@ is a constraint that proves that --- @fields@ has a field of @alias ::: field@, inferring @field@ --- from @alias@ and @fields@. -class KnownSymbol alias => - Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) - | alias fields -> field where -instance {-# OVERLAPPING #-} KnownSymbol alias - => Has alias (alias ::: field ': fields) field -instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field) - => Has 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 -choose which subfields to update. --} -class HasIn fields field where -instance (Has alias fields field) => HasIn fields (alias ::: field) where - --- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer --- a list of @subfields@. -class - ( SOP.All KnownSymbol aliases - ) => HasAll - (aliases :: [Symbol]) - (fields :: [(Symbol,kind)]) - (subfields :: [(Symbol,kind)]) - | aliases fields -> subfields where -instance {-# OVERLAPPING #-} HasAll '[] fields '[] -instance {-# OVERLAPPABLE #-} - (Has alias fields field, HasAll aliases fields subfields) - => HasAll (alias ': aliases) fields (alias ::: field ': subfields) - --- | Analagous to `IsLabel`, the constraint --- `IsQualified` defines `!` for a column alias qualified --- by a table alias. -class IsQualified table column expression where - (!) :: Alias table -> Alias column -> expression - infixl 9 ! -instance IsQualified table column (Alias table, Alias column) where (!) = (,) - -{-| `QualifiedAlias`es enables multi-schema support by allowing a reference -to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef` -or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default, -a qualifier of @public@ is provided. - ->>> :{ -let - alias1 :: QualifiedAlias "sch" "tab" - alias1 = #sch ! #tab - alias2 :: QualifiedAlias "public" "vw" - alias2 = #vw -in printSQL alias1 >> printSQL alias2 -:} -"sch"."tab" -"vw" --} -data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias - deriving (Eq,GHC.Generic,Ord,Show,NFData) -instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where - _!_ = QualifiedAlias -instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where - fromLabel = QualifiedAlias -instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) => - IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where - _!_ = QualifiedAlias `As` Alias -instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) => - IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where - fromLabel = QualifiedAlias `As` Alias - -instance (KnownSymbol q, KnownSymbol a) - => RenderSQL (QualifiedAlias q a) where - renderSQL _ = - let - qualifier = renderSQL (Alias @q) - alias = renderSQL (Alias @a) - in - if qualifier == "\"public\"" then alias else qualifier <> "." <> alias diff --git a/src/Squeal/PostgreSQL/Binary.hs b/src/Squeal/PostgreSQL/Binary.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Binary.hs +++ /dev/null @@ -1,757 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Binary -Description: Binary encoding and decoding -Copyright: (c) Eitan Chatav, 2017 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module provides binary encoding and decoding between Haskell and PostgreSQL types. - -Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely -do not need to define your own instances to decode retrieved rows into Haskell values or -to encode Haskell values into statement parameters. - -Let's see some examples. We'll need some imports - ->>> import Data.Int (Int16) ->>> import Data.Text (Text) ->>> import Control.Monad (void) ->>> import Control.Monad.IO.Class (liftIO) ->>> import Squeal.PostgreSQL - -Define a Haskell datatype @Row@ that will serve as both the input and output of a simple -round trip query. - ->>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic) ->>> instance Generic Row ->>> instance HasDatatypeInfo Row ->>> :{ -let - roundTrip :: Query_ (Public '[]) Row Row - roundTrip = values_ $ - parameter @1 int2 `as` #col1 :* - parameter @2 text `as` #col2 :* - parameter @3 bool `as` #col3 -:} - -So long as we can encode the parameters and then decode the result of the query, -the input and output should be equal. - ->>> let input = Row 2 "hi" (Just True) ->>> :{ -withConnection "host=localhost port=5432 dbname=exampledb" $ do - result <- runQueryParams roundTrip input - Just output <- firstRow result - liftIO . print $ input == output -:} -True - -In addition to being able to encode and decode basic Haskell types -like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to -Postgres array, enumerated and composite types and json. Let's see another example, -this time using the `Vector` type which corresponds to variable length arrays -and homogeneous tuples which correspond to fixed length arrays. We can even -create multi-dimensional fixed length arrays. - ->>> :{ -data Row = Row - { col1 :: VarArray (Vector Int16) - , col2 :: FixArray (Maybe Int16,Maybe Int16) - , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16)) - } deriving (Eq, GHC.Generic) -:} - ->>> instance Generic Row ->>> instance HasDatatypeInfo Row - -Once again, we define a simple round trip query. - ->>> :{ -let - roundTrip :: Query_ (Public '[]) Row Row - roundTrip = values_ $ - parameter @1 (int2 & vararray) `as` #col1 :* - parameter @2 (int2 & fixarray @'[2]) `as` #col2 :* - parameter @3 (int2 & fixarray @'[3,2]) `as` #col3 -:} - ->>> :set -XOverloadedLists ->>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6))) ->>> :{ -withConnection "host=localhost port=5432 dbname=exampledb" $ do - result <- runQueryParams roundTrip input - Just output <- firstRow result - liftIO . print $ input == output -:} -True - -Enumerated (enum) types are data types that comprise a static, ordered set of values. -They are equivalent to Haskell algebraic data types whose constructors are nullary. -An example of an enum type might be the days of the week, -or a set of status values for a piece of data. - ->>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic) ->>> instance Generic Schwarma ->>> instance HasDatatypeInfo Schwarma - -A composite type represents the structure of a row or record; -it is essentially just a list of field names and their data types. - ->>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic) ->>> instance Generic Person ->>> instance HasDatatypeInfo Person ->>> instance Aeson.FromJSON Person ->>> instance Aeson.ToJSON Person - -We can create the equivalent Postgres types directly from their Haskell types. - ->>> :{ -type Schema = - '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma)) - , "person" ::: 'Typedef (PG (Composite Person)) - ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public Schema) - setup = - createTypeEnumFrom @Schwarma #schwarma >>> - createTypeCompositeFrom @Person #person -:} - -Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@ -with enumerated, composite or json types in Postgres. First create a Haskell -@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields. - ->>> :{ -data Row = Row - { schwarma :: Enumerated Schwarma - , person1 :: Composite Person - , person2 :: Json Person - } deriving (Eq, GHC.Generic) -:} - ->>> instance Generic Row ->>> instance HasDatatypeInfo Row ->>> :{ -let - input = Row - (Enumerated Chicken) - (Composite (Person "Faisal" 24)) - (Json (Person "Ahmad" 48)) -:} - -Once again, define a round trip query. - ->>> :{ -let - roundTrip :: Query_ (Public Schema) Row Row - roundTrip = values_ $ - parameter @1 (typedef #schwarma) `as` #schwarma :* - parameter @2 (typedef #person) `as` #person1 :* - parameter @3 json `as` #person2 -:} - -Finally, we can drop our type definitions. - ->>> :{ -let - teardown :: Definition (Public Schema) (Public '[]) - teardown = dropType #schwarma >>> dropType #person -:} - -Now let's run it. - ->>> :{ -let - session = do - result <- runQueryParams roundTrip input - Just output <- firstRow result - liftIO . print $ input == output -in - withConnection "host=localhost port=5432 dbname=exampledb" $ - define setup - & pqThen session - & pqThen (define teardown) -:} -True --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DeriveFoldable - , DeriveFunctor - , DeriveGeneric - , DeriveTraversable - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , OverloadedStrings - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Binary - ( -- * Encoding - ToParam (..) - , ToParams (..) - , ToNullityParam (..) - , ToField (..) - , ToFixArray (..) - -- * Decoding - , FromValue (..) - , FromRow (..) - , FromField (..) - , FromFixArray (..) - -- * Only - , Only (..) - -- * Oid - , HasOid (..) - , HasAliasedOid (..) - ) where - -import BinaryParser -import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE) -import Control.Arrow (left) -import Control.Monad -import Data.Int -import Data.Kind -import Data.Scientific -import Data.Time -import Data.UUID.Types -import Data.Vector (Vector) -import Data.Word -import Generics.SOP -import Generics.SOP.Record -import GHC.TypeLits -import Network.IP.Addr - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Lazy as Lazy.ByteString -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text as Strict (Text) -import qualified Data.Text as Strict.Text -import qualified Data.Vector as Vector -import qualified GHC.Generics as GHC -import qualified PostgreSQL.Binary.Decoding as Decoding -import qualified PostgreSQL.Binary.Encoding as Encoding - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.PG -import Squeal.PostgreSQL.Schema - --- | A `ToParam` constraint gives an encoding of a Haskell `Type` into --- into the binary format of a PostgreSQL `PGType`. -class ToParam (x :: Type) (pg :: PGType) where - -- | >>> :set -XTypeApplications -XDataKinds - -- >>> toParam @Bool @'PGbool False - -- K "\NUL" - -- - -- >>> toParam @Int16 @'PGint2 0 - -- K "\NUL\NUL" - -- - -- >>> toParam @Int32 @'PGint4 0 - -- K "\NUL\NUL\NUL\NUL" - -- - -- >>> :set -XMultiParamTypeClasses - -- >>> newtype Id = Id { getId :: Int16 } deriving Show - -- >>> instance ToParam Id 'PGint2 where toParam = toParam . getId - -- >>> toParam @Id @'PGint2 (Id 1) - -- K "\NUL\SOH" - toParam :: x -> K Encoding.Encoding pg -instance ToParam Bool 'PGbool where toParam = K . Encoding.bool -instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16 -instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16 -instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32 -instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32 -instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64 -instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64 -instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4 -instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8 -instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric -instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents -instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid -instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet -instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8 -instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict -instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy -instance ToParam String 'PGtext where - toParam = K . Encoding.text_strict . Strict.Text.pack -instance ToParam Strict.ByteString 'PGbytea where - toParam = K . Encoding.bytea_strict -instance ToParam Lazy.ByteString 'PGbytea where - toParam = K . Encoding.bytea_lazy -instance ToParam Day 'PGdate where toParam = K . Encoding.date -instance ToParam TimeOfDay 'PGtime where toParam = K . Encoding.time_int -instance ToParam (TimeOfDay, TimeZone) 'PGtimetz where - toParam = K . Encoding.timetz_int -instance ToParam LocalTime 'PGtimestamp where - toParam = K . Encoding.timestamp_int -instance ToParam UTCTime 'PGtimestamptz where - toParam = K . Encoding.timestamptz_int -instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int -instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast -instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast -instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where - toParam = K . Encoding.json_bytes - . Lazy.ByteString.toStrict . Aeson.encode . getJson -instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where - toParam = K . Encoding.jsonb_bytes - . Lazy.ByteString.toStrict . Aeson.encode . getJsonb -instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg) - => ToParam (VarArray [x]) ('PGvararray ty) where - toParam = K - . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty) - . getVarArray -instance (ToParam x pg, HasOid pg) - => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where - toParam = K - . Encoding.array_vector (oid @pg) (unK . toParam @x @pg) - . getVarArray -instance (ToParam x pg, HasOid pg) - => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where - toParam = K - . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg) - . getVarArray -instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg) - => ToParam (FixArray x) ('PGfixarray dims ty) where - toParam = K . Encoding.array (oid @pg) - . unK . unK . toFixArray @x @dims @ty . getFixArray -instance - ( IsEnumType x - , HasDatatypeInfo x - , LabelsPG x ~ labels - ) => ToParam (Enumerated x) ('PGenum labels) where - toParam = - let - gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String - gshowConstructor Nil _ = "" - gshowConstructor (constructor :* _) (SOP (Z _)) = - constructorName constructor - gshowConstructor (_ :* constructors) (SOP (S xs)) = - gshowConstructor constructors (SOP xs) - in - K . Encoding.text_strict - . Strict.Text.pack - . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x))) - . from - . getEnumerated -instance - ( SListI fields - , IsRecord x xs - , AllZip ToField xs fields - , All HasAliasedOid fields - ) => ToParam (Composite x) ('PGcomposite fields) where - toParam = - let - - encoders = htrans (Proxy @ToField) toField - - composite - :: All HasAliasedOid row - => NP (K (Maybe Encoding.Encoding)) row - -> K Encoding.Encoding ('PGcomposite row) - composite fields = K $ - -- - -- [for each field] - -- - -- [if value is NULL] - -- <-1: 4 bytes> - -- [else] - -- - -- bytes> - -- [end if] - -- [end for] - int32BE (fromIntegral (lengthSList (Proxy @xs))) <> - let - each - :: HasAliasedOid field - => K (Maybe Encoding.Encoding) field - -> Encoding.Encoding - each (K field :: K (Maybe Encoding.Encoding) field) = - word32BE (aliasedOid @field) - <> case field of - Nothing -> int64BE (-1) - Just value -> - int32BE (fromIntegral (builderLength value)) - <> value - in - hcfoldMap (Proxy @HasAliasedOid) each fields - - in - composite . encoders . toRecord . getComposite - --- | The object identifier of a `PGType`. --- --- >>> :set -XTypeApplications --- >>> oid @'PGbool --- 16 -class HasOid (ty :: PGType) where oid :: Word32 -instance HasOid 'PGbool where oid = 16 -instance HasOid 'PGint2 where oid = 21 -instance HasOid 'PGint4 where oid = 23 -instance HasOid 'PGint8 where oid = 20 -instance HasOid 'PGnumeric where oid = 1700 -instance HasOid 'PGfloat4 where oid = 700 -instance HasOid 'PGfloat8 where oid = 701 -instance HasOid ('PGchar n) where oid = 18 -instance HasOid ('PGvarchar n) where oid = 1043 -instance HasOid 'PGtext where oid = 25 -instance HasOid 'PGbytea where oid = 17 -instance HasOid 'PGtimestamp where oid = 1114 -instance HasOid 'PGtimestamptz where oid = 1184 -instance HasOid 'PGdate where oid = 1082 -instance HasOid 'PGtime where oid = 1083 -instance HasOid 'PGtimetz where oid = 1266 -instance HasOid 'PGinterval where oid = 1186 -instance HasOid 'PGuuid where oid = 2950 -instance HasOid 'PGinet where oid = 869 -instance HasOid 'PGjson where oid = 114 -instance HasOid 'PGjsonb where oid = 3802 - --- | Lifts a `HasOid` constraint to a field. -class HasAliasedOid (field :: (Symbol, NullityType)) where - aliasedOid :: Word32 -instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where - aliasedOid = oid @ty - --- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into --- into the binary format of a PostgreSQL `NullityType`. -class ToNullityParam (x :: Type) (ty :: NullityType) where - toNullityParam :: x -> K (Maybe Encoding.Encoding) ty -instance ToParam x pg => ToNullityParam x ('NotNull pg) where - toNullityParam = K . Just . unK . toParam @x @pg -instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where - toNullityParam = K . fmap (unK . toParam @x @pg) - --- | A `ToField` constraint lifts the `ToParam` parser --- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@, --- encoding `Null`s to `Maybe`s. You should not define instances for --- `FromField`, just use the provided instances. -class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where - toField :: P x -> K (Maybe Encoding.Encoding) field -instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where - toField (P x) = K . unK $ toNullityParam @x @ty x - --- | A `ToFixArray` constraint gives an encoding of a Haskell `Type` --- into the binary format of a PostgreSQL fixed-length array. --- You should not define instances for --- `ToFixArray`, just use the provided instances. -class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where - toFixArray :: x -> K (K Encoding.Array dims) array -instance ToNullityParam x ty => ToFixArray x '[] ty where - toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK - . toNullityParam @x @ty -instance - ( IsProductType product xs - , Length xs ~ dim - , All ((~) x) xs - , ToFixArray x dims ty ) - => ToFixArray product (dim ': dims) ty where - toFixArray = K . K . Encoding.dimensionArray foldlN - (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from - --- | A `ToParams` constraint generically sequences the encodings of `Type`s --- of the fields of a tuple or record to a row of `ColumnType`s. You should --- not define instances of `ToParams`. Instead define `SOP.Generic` instances --- which in turn provide `ToParams` instances. -class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where - -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2] - -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0) - -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil - -- - -- >>> :set -XDeriveGeneric - -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic - -- >>> instance Generic Tuple - -- >>> toParams @Tuple @Params (Tuple False (Just 0)) - -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil - toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys -instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys) - => ToParams x tys where - toParams - = htrans (Proxy @ToNullityParam) (toNullityParam . unI) - . unZ . unSOP . from - --- | A `FromValue` constraint gives a parser from the binary format of --- a PostgreSQL `PGType` into a Haskell `Type`. -class FromValue (pg :: PGType) (y :: Type) where - -- | >>> newtype Id = Id { getId :: Int16 } deriving Show - -- >>> instance FromValue 'PGint2 Id where fromValue = Id <$> fromValue @'PGint2 - fromValue :: Decoding.Value y -instance FromValue 'PGbool Bool where fromValue = Decoding.bool -instance FromValue 'PGint2 Int16 where fromValue = Decoding.int -instance FromValue 'PGint4 Int32 where fromValue = Decoding.int -instance FromValue 'PGint8 Int64 where fromValue = Decoding.int -instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4 -instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8 -instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric -instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int -instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid -instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet -instance FromValue ('PGchar 1) Char where fromValue = Decoding.char -instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict -instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy -instance FromValue 'PGtext String where - fromValue = Strict.Text.unpack <$> Decoding.text_strict -instance FromValue 'PGbytea Strict.ByteString where - fromValue = Decoding.bytea_strict -instance FromValue 'PGbytea Lazy.ByteString where - fromValue = Decoding.bytea_lazy -instance FromValue 'PGdate Day where fromValue = Decoding.date -instance FromValue 'PGtime TimeOfDay where fromValue = Decoding.time_int -instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where - fromValue = Decoding.timetz_int -instance FromValue 'PGtimestamp LocalTime where - fromValue = Decoding.timestamp_int -instance FromValue 'PGtimestamptz UTCTime where - fromValue = Decoding.timestamptz_int -instance FromValue 'PGinterval DiffTime where - fromValue = Decoding.interval_int -instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast -instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast -instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where - fromValue = Json <$> - Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict) -instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where - fromValue = Jsonb <$> - Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict) -instance FromValue pg y - => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where - fromValue = - let - rep n x = VarArray <$> Vector.replicateM n x - in - Decoding.array $ Decoding.dimensionArray rep - (fromFixArray @'[] @('NotNull pg)) -instance FromValue pg y - => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where - fromValue = - let - rep n x = VarArray <$> Vector.replicateM n x - in - Decoding.array $ Decoding.dimensionArray rep - (fromFixArray @'[] @('Null pg)) -instance FromValue pg y - => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where - fromValue = - let - rep n x = VarArray <$> replicateM n x - in - Decoding.array $ Decoding.dimensionArray rep - (fromFixArray @'[] @('NotNull pg)) -instance FromValue pg y - => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where - fromValue = - let - rep n x = VarArray <$> replicateM n x - in - Decoding.array $ Decoding.dimensionArray rep - (fromFixArray @'[] @('Null pg)) -instance FromFixArray dims ty y - => FromValue ('PGfixarray dims ty) (FixArray y) where - fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y) -instance - ( IsEnumType y - , HasDatatypeInfo y - , LabelsPG y ~ labels - ) => FromValue ('PGenum labels) (Enumerated y) where - fromValue = - let - greadConstructor - :: All ((~) '[]) xss - => NP ConstructorInfo xss - -> String - -> Maybe (SOP I xss) - greadConstructor Nil _ = Nothing - greadConstructor (constructor :* constructors) name = - if name == constructorName constructor - then Just (SOP (Z Nil)) - else SOP . S . unSOP <$> greadConstructor constructors name - in - fmap Enumerated - . Decoding.enum - $ fmap to - . greadConstructor (constructorInfo (datatypeInfo (Proxy @y))) - . Strict.Text.unpack -instance - ( FromRow fields y - ) => FromValue ('PGcomposite fields) (Composite y) where - fromValue = - let - -- - -- [for each field] - -- - -- [if value is NULL] - -- <-1: 4 bytes> - -- [else] - -- - -- bytes> - -- [end if] - -- [end for] - composite = Decoding.valueParser $ do - unitOfSize 4 - hsequence' $ hpure $ Comp $ do - unitOfSize 4 - len <- sized 4 Decoding.int - if len == -1 - then return (K Nothing) - else K . Just <$> bytesOfSize len - in - fmap Composite (Decoding.fn (fromRow @fields <=< composite)) - --- | A `FromField` constraint lifts the `FromValue` parser --- to a decoding of a @(Symbol, NullityType)@ to a `Type`, --- decoding `Null`s to `Maybe`s. You should not define instances for --- `FromField`, just use the provided instances. -class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where - fromField - :: K (Maybe Strict.ByteString) pg - -> (Either Strict.Text :.: P) y -instance FromValue pg y - => FromField (column ::: ('NotNull pg)) (column ::: y) where - fromField = Comp . \case - K Nothing -> Left "fromField: saw NULL when expecting NOT NULL" - K (Just bytestring) -> P <$> - Decoding.valueParser (fromValue @pg) bytestring -instance FromValue pg y - => FromField (column ::: 'Null pg) (column ::: Maybe y) where - fromField = Comp . \case - K Nothing -> Right $ P Nothing - K (Just bytestring) -> P . Just <$> - Decoding.valueParser (fromValue @pg) bytestring - --- | A `FromFixArray` constraint gives a decoding to a Haskell `Type` --- from the binary format of a PostgreSQL fixed-length array. --- You should not define instances for --- `FromFixArray`, just use the provided instances. -class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where - fromFixArray :: Decoding.Array y -instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where - fromFixArray = Decoding.valueArray (fromValue @pg @y) -instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where - fromFixArray = Decoding.nullableValueArray (fromValue @pg @y) -instance - ( IsProductType product ys - , Length ys ~ dim - , All ((~) y) ys - , FromFixArray dims ty y ) - => FromFixArray (dim ': dims) ty product where - fromFixArray = - let - rep _ = fmap (to . SOP . Z) . replicateMN - in - Decoding.dimensionArray rep (fromFixArray @dims @ty @y) - --- | A `FromRow` constraint generically sequences the parsings of the columns --- of a `RowType` into the fields of a record `Type` provided they have --- the same field names. You should not define instances of `FromRow`. --- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn --- provide `FromRow` instances. -class SListI result => FromRow (result :: RowType) y where - -- | >>> :set -XOverloadedStrings - -- >>> import Data.Text - -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show - -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2 - -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic) - -- >>> instance Generic UserRow - -- >>> instance HasDatatypeInfo UserRow - -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext] - -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil) - -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}) - fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y -instance - ( SListI result - , IsRecord y ys - , AllZip FromField result ys - ) => FromRow result y where - fromRow - = fmap fromRecord - . hsequence' - . htrans (Proxy @FromField) fromField ------------------------------------------------------- --- P records ------------------------------------------------------- --- instance (FromField (col ::: pg) (col ::: hask)) --- => FromRow '[col ::: pg] (P (col ::: hask)) where --- fromRow (pg :* Nil) = (unComp . fromField) pg --- instance --- ( row ~ Join row1 row2 --- , FromRow row1 hask1 --- , FromRow row2 hask2 --- , SListI row --- ) => FromRow row (hask1, hask2) where --- fromRow row = case disjoin @row1 @row2 row of --- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2 --- instance --- ( row ~ Join row1 row23 --- , FromRow row1 hask1 --- , FromRow row23 (hask2, hask3) --- , SListI row --- ) => FromRow row (hask1, hask2, hask3) where --- fromRow row = case disjoin @row1 @row23 row of --- (row1, row23) -> do --- hask1 <- fromRow row1 --- (hask2, hask3) <- fromRow row23 --- return (hask1, hask2, hask3) --- instance --- ( row ~ Join row1 row234 --- , FromRow row1 hask1 --- , FromRow row234 (hask2, hask3, hask4) --- , SListI row --- ) => FromRow row (hask1, hask2, hask3, hask4) where --- fromRow row = case disjoin @row1 @row234 row of --- (row1, row234) -> do --- hask1 <- fromRow row1 --- (hask2, hask3, hask4) <- fromRow row234 --- return (hask1, hask2, hask3, hask4) --- instance --- ( row ~ Join row1 row2345 --- , FromRow row1 hask1 --- , FromRow row2345 (hask2, hask3, hask4, hask5) --- , SListI row --- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where --- fromRow row = case disjoin @row1 @row2345 row of --- (row1, row2345) -> do --- hask1 <- fromRow row1 --- (hask2, hask3, hask4, hask5) <- fromRow row2345 --- return (hask1, hask2, hask3, hask4, hask5) - --- | `Only` is a 1-tuple type, useful for encoding a single parameter with --- `toParams` or decoding a single value with `fromRow`. --- --- >>> import Data.Text --- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo")) --- K (Just "foo") :* Nil --- --- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil) --- Right (Only {fromOnly = Just "bar"}) -newtype Only x = Only { fromOnly :: x } - deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic) -instance Generic (Only x) -instance HasDatatypeInfo (Only x) - -foldlN - :: All ((~) x) xs - => (z -> x -> z) -> z -> NP I xs -> z -foldlN f z = \case - Nil -> z - I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs - -replicateMN - :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs) - => m x -> m (NP I xs) -replicateMN mx = hsequence' $ - hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx)) diff --git a/src/Squeal/PostgreSQL/Definition.hs b/src/Squeal/PostgreSQL/Definition.hs --- a/src/Squeal/PostgreSQL/Definition.hs +++ b/src/Squeal/PostgreSQL/Definition.hs @@ -1,1110 +1,88 @@ {-| Module: Squeal.PostgreSQL.Definition -Description: Squeal data definition language -Copyright: (c) Eitan Chatav, 2017 -Maintainer: eitan@morphism.tech -Stability: experimental - -Squeal data definition language. --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition - ( -- * Definition - Definition (..) - , (>>>) - , manipDefinition - -- * Tables - -- ** Create - , createSchema - , createSchemaIfNotExists - , createTable - , createTableIfNotExists - , createView - , createTypeEnum - , createTypeEnumFrom - , createTypeComposite - , createTypeCompositeFrom - , FieldTyped (..) - , createDomain - , TableConstraintExpression (..) - , check - , unique - , primaryKey - , foreignKey - , ForeignKeyed - , OnDeleteClause (..) - , OnUpdateClause (..) - -- ** Drop - , dropSchema - , dropTable - , dropView - , dropType - -- ** Alter - , alterTable - , alterTableRename - , AlterTable (..) - , addConstraint - , dropConstraint - , AddColumn (..) - , dropColumn - , renameColumn - , alterColumn - , AlterColumn (..) - , setDefault - , dropDefault - , setNotNull - , dropNotNull - , alterType - -- * Columns - , ColumnTypeExpression (..) - , nullable - , notNullable - , default_ - , serial2 - , smallserial - , serial4 - , serial - , serial8 - , bigserial - ) where - -import Control.Category -import Control.DeepSeq -import Data.ByteString -import Data.Monoid -import GHC.TypeLits -import Prelude hiding ((.), id) - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.PG -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -statements ------------------------------------------} - --- | A `Definition` is a statement that changes the schemas of the --- database, like a `createTable`, `dropTable`, or `alterTable` command. --- `Definition`s may be composed using the `>>>` operator. -newtype Definition - (schemas0 :: SchemasType) - (schemas1 :: SchemasType) - = UnsafeDefinition { renderDefinition :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) - -instance RenderSQL (Definition schemas0 schemas1) where - renderSQL = renderDefinition - -instance Category Definition where - id = UnsafeDefinition ";" - ddl1 . ddl0 = UnsafeDefinition $ - renderSQL ddl0 <> "\n" <> renderSQL ddl1 - --- | A `Manipulation` without input or output can be run as a statement --- along with other `Definition`s, by embedding it using `manipDefinition`. -manipDefinition - :: Manipulation '[] schemas '[] '[] - -- ^ no input or output - -> Definition schemas schemas -manipDefinition = UnsafeDefinition . (<> ";") . renderSQL - -{----------------------------------------- -CREATE statements ------------------------------------------} - -{- | -`createSchema` enters a new schema into the current database. -The schema name must be distinct from the name of any existing schema -in the current database. - -A schema is essentially a namespace: it contains named objects -(tables, data types, functions, and operators) whose names -can duplicate those of other objects existing in other schemas. -Named objects are accessed by `QualifiedAlias`es with the schema -name as a prefix. --} -createSchema - :: KnownSymbol sch - => Alias sch - -> Definition schemas (Create sch '[] schemas) -createSchema sch = UnsafeDefinition $ - "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";" - -{- | Idempotent version of `createSchema`. -} -createSchemaIfNotExists - :: (KnownSymbol sch, Has sch schemas schema) - => Alias sch - -> Definition schemas schemas -createSchemaIfNotExists sch = UnsafeDefinition $ - "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS" - <+> renderSQL sch <> ";" - -{- | `createTable` adds a table to the schema. - ->>> :set -XOverloadedLabels ->>> :{ -type Table = '[] :=> - '[ "a" ::: 'NoDef :=> 'Null 'PGint4 - , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table]) - setup = createTable #tab - (nullable int `as` #a :* nullable real `as` #b) Nil -in printSQL setup -:} -CREATE TABLE "tab" ("a" int NULL, "b" real NULL); --} -createTable - :: ( KnownSymbol sch - , KnownSymbol tab - , columns ~ (col ': cols) - , SOP.SListI columns - , SOP.SListI constraints - , Has sch schemas0 schema0 - , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 ) - => QualifiedAlias sch tab -- ^ the name of the table to add - -> NP (Aliased (ColumnTypeExpression schemas0)) columns - -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints - -- ^ constraints that must hold for the table - -> Definition schemas0 schemas1 -createTable tab columns constraints = UnsafeDefinition $ - "CREATE TABLE" <+> renderCreation tab columns constraints - -{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. -Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. -`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in -the `Category` of `Definition`s. - ->>> :set -XOverloadedLabels -XTypeApplications ->>> :{ -type Table = '[] :=> - '[ "a" ::: 'NoDef :=> 'Null 'PGint4 - , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] -:} - ->>> type Schemas = Public '["tab" ::: 'Table Table] - ->>> :{ -let - setup :: Definition Schemas Schemas - setup = createTableIfNotExists #tab - (nullable int `as` #a :* nullable real `as` #b) Nil -in printSQL setup -:} -CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); --} -createTableIfNotExists - :: ( Has sch schemas schema - , Has tab schema ('Table (constraints :=> columns)) - , SOP.SListI columns - , SOP.SListI constraints ) - => QualifiedAlias sch tab -- ^ the name of the table to add - -> NP (Aliased (ColumnTypeExpression schemas)) columns - -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints - -- ^ constraints that must hold for the table - -> Definition schemas schemas -createTableIfNotExists tab columns constraints = UnsafeDefinition $ - "CREATE TABLE IF NOT EXISTS" - <+> renderCreation tab columns constraints - --- helper function for `createTable` and `createTableIfNotExists` -renderCreation - :: ( KnownSymbol sch - , KnownSymbol tab - , SOP.SListI columns - , SOP.SListI constraints ) - => QualifiedAlias sch tab -- ^ the name of the table to add - -> NP (Aliased (ColumnTypeExpression schemas0)) columns - -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints - -- ^ constraints that must hold for the table - -> ByteString -renderCreation tab columns constraints = renderSQL tab - <+> parenthesized - ( renderCommaSeparated renderColumnDef columns - <> ( case constraints of - Nil -> "" - _ -> ", " <> - renderCommaSeparated renderConstraint constraints ) ) - <> ";" - where - renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString - renderColumnDef (ty `As` column) = - renderSQL column <+> renderColumnTypeExpression ty - renderConstraint - :: Aliased (TableConstraintExpression sch tab schemas) constraint - -> ByteString - renderConstraint (constraint `As` alias) = - "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint - --- | Data types are a way to limit the kind of data that can be stored in a --- table. For many applications, however, the constraint they provide is --- too coarse. For example, a column containing a product price should --- probably only accept positive values. But there is no standard data type --- that accepts only positive numbers. Another issue is that you might want --- to constrain column data with respect to other columns or rows. --- For example, in a table containing product information, --- there should be only one row for each product number. --- `TableConstraint`s give you as much control over the data in your tables --- as you wish. If a user attempts to store data in a column that would --- violate a constraint, an error is raised. This applies --- even if the value came from the default value definition. -newtype TableConstraintExpression - (sch :: Symbol) - (tab :: Symbol) - (schemas :: SchemasType) - (constraint :: TableConstraint) - = UnsafeTableConstraintExpression - { renderTableConstraintExpression :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL - (TableConstraintExpression sch tab schemas constraint) where - renderSQL = renderTableConstraintExpression - -{-| A `check` constraint is the most generic `TableConstraint` type. -It allows you to specify that the value in a certain column must satisfy -a Boolean (truth-value) expression. - ->>> :{ -type Schema = '[ - "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[ - "a" ::: 'NoDef :=> 'NotNull 'PGint4, - "b" ::: 'NoDef :=> 'NotNull 'PGint4 - ])] -:} - ->>> :{ -let - definition :: Definition (Public '[]) (Public Schema) - definition = createTable #tab - ( (int & notNullable) `as` #a :* - (int & notNullable) `as` #b ) - ( check (#a :* #b) (#a .> #b) `as` #inequality ) -:} - ->>> printSQL definition -CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); --} -check - :: ( Has sch schemas schema - , Has tab schema ('Table table) - , HasAll aliases (TableToRow table) subcolumns ) - => NP Alias aliases - -- ^ specify the subcolumns which are getting checked - -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns]) - -- ^ a closed `Condition` on those subcolumns - -> TableConstraintExpression sch tab schemas ('Check aliases) -check _cols condition = UnsafeTableConstraintExpression $ - "CHECK" <+> parenthesized (renderSQL condition) - -{-| A `unique` constraint ensure that the data contained in a column, -or a group of columns, is unique among all the rows in the table. - ->>> :{ -type Schema = '[ - "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[ - "a" ::: 'NoDef :=> 'Null 'PGint4, - "b" ::: 'NoDef :=> 'Null 'PGint4 - ])] -:} - ->>> :{ -let - definition :: Definition (Public '[]) (Public Schema) - definition = createTable #tab - ( (int & nullable) `as` #a :* - (int & nullable) `as` #b ) - ( unique (#a :* #b) `as` #uq_a_b ) -:} - ->>> printSQL definition -CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); --} -unique - :: ( Has sch schemas schema - , Has tab schema('Table table) - , HasAll aliases (TableToRow table) subcolumns ) - => NP Alias aliases - -- ^ specify subcolumns which together are unique for each row - -> TableConstraintExpression sch tab schemas ('Unique aliases) -unique columns = UnsafeTableConstraintExpression $ - "UNIQUE" <+> parenthesized (renderSQL columns) - -{-| A `primaryKey` constraint indicates that a column, or group of columns, -can be used as a unique identifier for rows in the table. -This requires that the values be both unique and not null. - ->>> :{ -type Schema = '[ - "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[ - "id" ::: 'Def :=> 'NotNull 'PGint4, - "name" ::: 'NoDef :=> 'NotNull 'PGtext - ])] -:} - ->>> :{ -let - definition :: Definition (Public '[]) (Public Schema) - definition = createTable #tab - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_id ) -:} - ->>> printSQL definition -CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); --} -primaryKey - :: ( Has sch schemas schema - , Has tab schema ('Table table) - , HasAll aliases (TableToColumns table) subcolumns - , AllNotNull subcolumns ) - => NP Alias aliases - -- ^ specify the subcolumns which together form a primary key. - -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases) -primaryKey columns = UnsafeTableConstraintExpression $ - "PRIMARY KEY" <+> parenthesized (renderSQL columns) - -{-| A `foreignKey` specifies that the values in a column -(or a group of columns) must match the values appearing in some row of -another table. We say this maintains the referential integrity -between two related tables. - ->>> :{ -type Schema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) - , "emails" ::: 'Table ( - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) - ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public Schema) - setup = - createTable #users - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_users ) >>> - createTable #emails - ( serial `as` #id :* - (int & notNullable) `as` #user_id :* - (text & nullable) `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) -in printSQL setup -:} -CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); -CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); - -A `foreignKey` can even be a table self-reference. - ->>> :{ -type Schema = - '[ "employees" ::: 'Table ( - '[ "employees_pk" ::: 'PrimaryKey '["id"] - , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - , "employer_id" ::: 'NoDef :=> 'Null 'PGint4 - ]) - ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public Schema) - setup = - createTable #employees - ( serial `as` #id :* - (text & notNullable) `as` #name :* - (integer & nullable) `as` #employer_id ) - ( primaryKey #id `as` #employees_pk :* - foreignKey #employer_id #employees #id - OnDeleteCascade OnUpdateCascade `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 schemas sch schema child parent - table reftable - columns refcolumns - constraints cols - reftys tys ) - => NP Alias columns - -- ^ column or columns in the table - -> Alias parent - -- ^ reference table - -> NP Alias refcolumns - -- ^ reference column or columns in the reference table - -> OnDeleteClause - -- ^ what to do when reference is deleted - -> OnUpdateClause - -- ^ what to do when reference is updated - -> TableConstraintExpression sch child schemas - ('ForeignKey columns parent refcolumns) -foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ - "FOREIGN KEY" <+> parenthesized (renderSQL keys) - <+> "REFERENCES" <+> renderSQL parent - <+> parenthesized (renderSQL refs) - <+> renderSQL ondel - <+> renderSQL onupd - --- | A constraint synonym between types involved in a foreign key constraint. -type ForeignKeyed schemas - sch - schema - child parent - table reftable - columns refcolumns - constraints cols - reftys tys = - ( Has sch schemas schema - , Has child schema ('Table table) - , Has parent schema ('Table reftable) - , HasAll columns (TableToColumns table) tys - , reftable ~ (constraints :=> cols) - , HasAll refcolumns cols reftys - , SOP.AllZip SamePGType tys reftys - , 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 - 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" - --- | 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) - deriving (GHC.Generic,Show,Eq,Ord) -instance NFData OnUpdateClause - --- | Render `OnUpdateClause`. -instance RenderSQL OnUpdateClause where - renderSQL = \case - OnUpdateNoAction -> "ON UPDATE NO ACTION" - OnUpdateRestrict -> "ON UPDATE RESTRICT" - OnUpdateCascade -> "ON UPDATE CASCADE" - -{----------------------------------------- -DROP statements ------------------------------------------} - --- | >>> :{ --- let --- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public] --- definition = dropSchema #muh_schema --- :} --- --- >>> printSQL definition --- DROP SCHEMA "muh_schema"; -dropSchema - :: Has sch schemas schema - => Alias sch - -> Definition schemas (Drop sch schemas) -dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";" - --- | `dropTable` removes a table from the schema. --- --- >>> :{ --- let --- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[]) --- definition = dropTable #muh_table --- :} --- --- >>> printSQL definition --- DROP TABLE "muh_table"; -dropTable - :: ( Has sch schemas schema - , Has tab schema ('Table table)) - => QualifiedAlias sch tab -- ^ table to remove - -> Definition schemas (Alter sch (Drop tab schema) schemas) -dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";" - -{----------------------------------------- -ALTER statements ------------------------------------------} - --- | `alterTable` changes the definition of a table from the schema. -alterTable - :: (Has sch schemas schema, Has tab schema ('Table table0)) - => QualifiedAlias sch tab -- ^ table to alter - -> AlterTable sch tab schemas table1 -- ^ alteration to perform - -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas) -alterTable tab alteration = UnsafeDefinition $ - "ALTER TABLE" - <+> renderSQL tab - <+> renderAlterTable alteration - <> ";" - --- | `alterTableRename` changes the name of a table from the schema. --- --- >>> printSQL $ alterTableRename #foo #bar --- ALTER TABLE "foo" RENAME TO "bar"; -alterTableRename - :: (KnownSymbol table0, KnownSymbol table1) - => Alias table0 -- ^ table to rename - -> Alias table1 -- ^ what to rename it - -> Definition schema (Rename table0 table1 schema) -alterTableRename table0 table1 = UnsafeDefinition $ - "ALTER TABLE" <+> renderSQL table0 - <+> "RENAME TO" <+> renderSQL table1 <> ";" - --- | An `AlterTable` describes the alteration to perform on the columns --- of a table. -newtype AlterTable - (sch :: Symbol) - (tab :: Symbol) - (schemas :: SchemasType) - (table :: TableType) = - UnsafeAlterTable {renderAlterTable :: ByteString} - deriving (GHC.Generic,Show,Eq,Ord,NFData) - --- | An `addConstraint` adds a table constraint. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0))) --- in printSQL definition --- :} --- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0)); -addConstraint - :: ( KnownSymbol alias - , Has sch schemas schema - , Has tab schema ('Table table0) - , table0 ~ (constraints :=> columns) - , table1 ~ (Create alias constraint constraints :=> columns) ) - => Alias alias - -> TableConstraintExpression sch tab schemas constraint - -- ^ constraint to add - -> AlterTable sch tab schemas table1 -addConstraint alias constraint = UnsafeAlterTable $ - "ADD" <+> "CONSTRAINT" <+> renderSQL alias - <+> renderSQL constraint - --- | A `dropConstraint` drops a table constraint. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- definition = alterTable #tab (dropConstraint #positive) --- in printSQL definition --- :} --- ALTER TABLE "tab" DROP CONSTRAINT "positive"; -dropConstraint - :: ( KnownSymbol constraint - , Has sch schemas schema - , Has tab schema ('Table table0) - , table0 ~ (constraints :=> columns) - , table1 ~ (Drop constraint constraints :=> columns) ) - => Alias constraint - -- ^ constraint to drop - -> AlterTable sch tab schemas table1 -dropConstraint constraint = UnsafeAlterTable $ - "DROP" <+> "CONSTRAINT" <+> renderSQL constraint - --- | An `AddColumn` is either @NULL@ or has @DEFAULT@. -class AddColumn ty where - -- | `addColumn` adds a new column, initially filled with whatever - -- default value is given or with @NULL@. - -- - -- >>> :{ - -- let - -- definition :: Definition - -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] - -- '["public" ::: '["tab" ::: 'Table ('[] :=> - -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]] - -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) - -- in printSQL definition - -- :} - -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo'; - -- - -- >>> :{ - -- let - -- definition :: Definition - -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] - -- '["public" ::: '["tab" ::: 'Table ('[] :=> - -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] - -- definition = alterTable #tab (addColumn #col2 (text & nullable)) - -- in printSQL definition - -- :} - -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; - addColumn - :: ( KnownSymbol column - , Has sch schemas schema - , Has tab schema ('Table table0) - , table0 ~ (constraints :=> columns) ) - => Alias column -- ^ column to add - -> ColumnTypeExpression schemas ty -- ^ type of the new column - -> AlterTable sch tab schemas (constraints :=> Create column ty columns) - addColumn column ty = UnsafeAlterTable $ - "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty -instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) -instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) - --- | A `dropColumn` removes a column. Whatever data was in the column --- disappears. Table constraints involving the column are dropped, too. --- However, if the column is referenced by a foreign key constraint of --- another table, PostgreSQL will not silently drop that constraint. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> --- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 --- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (dropColumn #col2) --- in printSQL definition --- :} --- ALTER TABLE "tab" DROP COLUMN "col2"; -dropColumn - :: ( KnownSymbol column - , Has sch schemas schema - , Has tab schema ('Table table0) - , table0 ~ (constraints :=> columns) - , table1 ~ (constraints :=> Drop column columns) ) - => Alias column -- ^ column to remove - -> AlterTable sch tab schemas table1 -dropColumn column = UnsafeAlterTable $ - "DROP COLUMN" <+> renderSQL column - --- | A `renameColumn` renames a column. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (renameColumn #foo #bar) --- in printSQL definition --- :} --- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar"; -renameColumn - :: ( KnownSymbol column0 - , KnownSymbol column1 - , Has sch schemas schema - , Has tab schema ('Table table0) - , table0 ~ (constraints :=> columns) - , table1 ~ (constraints :=> Rename column0 column1 columns) ) - => Alias column0 -- ^ column to rename - -> Alias column1 -- ^ what to rename the column - -> AlterTable sch tab schemas table1 -renameColumn column0 column1 = UnsafeAlterTable $ - "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1 - --- | An `alterColumn` alters a single column. -alterColumn - :: ( KnownSymbol column - , Has sch schemas schema - , Has tab schema ('Table table0) - , table0 ~ (constraints :=> columns) - , Has column columns ty0 - , table1 ~ (constraints :=> Alter column ty1 columns)) - => Alias column -- ^ column to alter - -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform - -> AlterTable sch tab schemas table1 -alterColumn column alteration = UnsafeAlterTable $ - "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration - --- | An `AlterColumn` describes the alteration to perform on a single column. -newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) = - UnsafeAlterColumn {renderAlterColumn :: ByteString} - deriving (GHC.Generic,Show,Eq,Ord,NFData) - --- | A `setDefault` sets a new default for a column. Note that this doesn't --- affect any existing rows in the table, it just changes the default for --- future insert and update commands. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] --- definition = alterTable #tab (alterColumn #col (setDefault 5)) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5; -setDefault - :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set - -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty) -setDefault expression = UnsafeAlterColumn $ - "SET DEFAULT" <+> renderExpression expression - --- | A `dropDefault` removes any default value for a column. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (alterColumn #col dropDefault) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT; -dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty) -dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" - --- | A `setNotNull` adds a @NOT NULL@ constraint to a column. --- The constraint will be checked immediately, so the table data must satisfy --- the constraint before it can be added. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- definition = alterTable #tab (alterColumn #col setNotNull) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; -setNotNull - :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) -setNotNull = UnsafeAlterColumn $ "SET NOT NULL" - --- | A `dropNotNull` drops a @NOT NULL@ constraint from a column. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (alterColumn #col dropNotNull) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; -dropNotNull - :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) -dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" - --- | An `alterType` converts a column to a different data type. --- This will succeed only if each existing entry in the column can be --- converted to the new type by an implicit cast. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]] --- definition = --- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL; -alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty -alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty - -{- | Create a view. ->>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] ->>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] ->>> :{ -let - definition :: Definition - '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] - '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] - definition = - createView #bc (select_ (#b :* #c) (from (table #abc))) -in printSQL definition -:} -CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; --} -createView - :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema) - => QualifiedAlias sch vw -- ^ the name of the view to add - -> Query '[] '[] schemas '[] view -- ^ query - -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas) -createView alias query = UnsafeDefinition $ - "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS" - <+> renderQuery query <> ";" - --- | Drop a view. --- --- >>> :{ --- let --- definition :: Definition --- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) --- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] --- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = dropView #bc --- in printSQL definition --- :} --- DROP VIEW "bc"; -dropView - :: (Has sch schemas schema, Has vw schema ('View view)) - => QualifiedAlias sch vw -- ^ view to remove - -> Definition schemas (Alter sch (Drop vw schema) schemas) -dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";" - --- | Enumerated types are created using the `createTypeEnum` command, for example --- --- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]]) --- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); -createTypeEnum - :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels) - => QualifiedAlias sch enum - -- ^ name of the user defined enumerated type - -> NP PGlabel labels - -- ^ labels of the enumerated type - -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas) -createTypeEnum enum labels = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+> - parenthesized (renderSQL labels) <> ";" - --- | Enumerated types can also be generated from a Haskell type, for example --- --- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic --- >>> instance SOP.Generic Schwarma --- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> :{ --- let --- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] --- createSchwarma = createTypeEnumFrom @Schwarma #schwarma --- in --- printSQL createSchwarma --- :} --- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); -createTypeEnumFrom - :: forall hask sch enum schemas schema. - ( SOP.Generic hask - , SOP.All KnownSymbol (LabelsPG hask) - , KnownSymbol enum - , Has sch schemas schema ) - => QualifiedAlias sch enum - -- ^ name of the user defined enumerated type - -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas) -createTypeEnumFrom enum = createTypeEnum enum - (SOP.hpure label :: NP PGlabel (LabelsPG hask)) - -{- | `createTypeComposite` creates a composite type. The composite type is -specified by a list of attribute names and data types. - ->>> :{ -type PGcomplex = 'PGcomposite - '[ "real" ::: 'NotNull 'PGfloat8 - , "imaginary" ::: 'NotNull 'PGfloat8 ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]] - setup = createTypeComposite #complex - (float8 `as` #real :* float8 `as` #imaginary) -in printSQL setup -:} -CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); --} -createTypeComposite - :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields) - => QualifiedAlias sch ty - -- ^ name of the user defined composite type - -> NP (Aliased (TypeExpression schemas)) fields - -- ^ list of attribute names and data types - -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas) -createTypeComposite ty fields = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized - (renderCommaSeparated renderField fields) <> ";" - where - renderField :: Aliased (TypeExpression schemas) x -> ByteString - renderField (typ `As` alias) = - renderSQL alias <+> renderSQL typ - --- | Composite types can also be generated from a Haskell type, for example --- --- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic --- >>> instance SOP.Generic Complex --- >>> instance SOP.HasDatatypeInfo Complex --- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))] --- >>> :{ --- let --- createComplex :: Definition (Public '[]) (Public Schema) --- createComplex = createTypeCompositeFrom @Complex #complex --- in --- printSQL createComplex --- :} --- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); -createTypeCompositeFrom - :: forall hask sch ty schemas schema. - ( SOP.All (FieldTyped schemas) (RowPG hask) - , KnownSymbol ty - , Has sch schemas schema ) - => QualifiedAlias sch ty - -- ^ name of the user defined composite type - -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas) -createTypeCompositeFrom ty = createTypeComposite ty - (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype - :: NP (Aliased (TypeExpression schemas)) (RowPG hask)) - -{-| -`createDomain` creates a new domain. A domain is essentially a data type -with constraints (restrictions on the allowed set of values). - -Domains are useful for abstracting common constraints on fields -into a single location for maintenance. For example, several tables might -contain email address columns, all requiring the same `check` constraint -to verify the address syntax. Define a domain rather than setting up -each table's constraint individually. - ->>> :{ -let - createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4]) - createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull)) -in printSQL createPositive -:} -CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL)); --} -createDomain - :: (Has sch schemas schema, KnownSymbol dom) - => QualifiedAlias sch dom - -> (forall nullity. TypeExpression schemas (nullity ty)) - -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]]) - -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas) -createDomain dom ty condition = - UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom - <+> "AS" <+> renderTypeExpression ty - <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";" - --- | Lift `PGTyped` to a field -class FieldTyped schemas ty where - fieldtype :: Aliased (TypeExpression schemas) ty -instance (KnownSymbol alias, PGTyped schemas ty) - => FieldTyped schemas (alias ::: ty) where - fieldtype = pgtype `As` Alias - --- | Drop a type. --- --- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic --- >>> instance SOP.Generic Schwarma --- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[])) --- DROP TYPE "schwarma"; -dropType - :: (Has sch schemas schema, Has td schema ('Typedef ty)) - => QualifiedAlias sch td - -- ^ name of the user defined type - -> Definition schemas (Alter sch (Drop td schema) schemas) -dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";" - --- | `ColumnTypeExpression`s are used in `createTable` commands. -newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType) - = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (ColumnTypeExpression schemas ty) where - renderSQL = renderColumnTypeExpression - --- | used in `createTable` commands as a column constraint to note that --- @NULL@ may be present in a column -nullable - :: TypeExpression schemas (nullity ty) - -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty) -nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL" - --- | used in `createTable` commands as a column constraint to ensure --- @NULL@ is not present in a column -notNullable - :: TypeExpression schemas (nullity ty) - -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty) -notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL" - --- | used in `createTable` commands as a column constraint to give a default -default_ - :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty - -> ColumnTypeExpression schemas ('NoDef :=> ty) - -> ColumnTypeExpression schemas ('Def :=> ty) -default_ x ty = UnsafeColumnTypeExpression $ - renderSQL ty <+> "DEFAULT" <+> renderExpression x - --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `PGint2` -serial2, smallserial - :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2) -serial2 = UnsafeColumnTypeExpression "serial2" -smallserial = UnsafeColumnTypeExpression "smallserial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `PGint4` -serial4, serial - :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4) -serial4 = UnsafeColumnTypeExpression "serial4" -serial = UnsafeColumnTypeExpression "serial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `PGint8` -serial8, bigserial - :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8) -serial8 = UnsafeColumnTypeExpression "serial8" -bigserial = UnsafeColumnTypeExpression "bigserial" +Description: data definition language +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +data definition language +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Definition + ( -- * Definition + Definition (..) + , (>>>) + , manipulation_ + ) where + +import Control.Category +import Control.DeepSeq +import Data.ByteString +import Data.Monoid +import Prelude hiding ((.), id) + +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{----------------------------------------- +statements +-----------------------------------------} + +-- | A `Definition` is a statement that changes the schemas of the +-- database, like a `Squeal.PostgreSQL.Definition.Table.createTable`, +-- `Squeal.PostgreSQL.Definition.Table.dropTable`, +-- or `Squeal.PostgreSQL.Definition.Table.alterTable` command. +-- `Definition`s may be composed using the `>>>` operator. +newtype Definition + (db0 :: SchemasType) + (db1 :: SchemasType) + = UnsafeDefinition { renderDefinition :: ByteString } + deriving (GHC.Generic,Show,Eq,Ord,NFData) + +instance RenderSQL (Definition db0 db1) where + renderSQL = renderDefinition + +instance Category Definition where + id = UnsafeDefinition ";" + ddl1 . ddl0 = UnsafeDefinition $ + renderSQL ddl0 <> "\n" <> renderSQL ddl1 + +instance db0 ~ db1 => Semigroup (Definition db0 db1) where (<>) = (>>>) +instance db0 ~ db1 => Monoid (Definition db0 db1) where mempty = id + +-- | A `Manipulation` without input or output can be run as a statement +-- along with other `Definition`s, by embedding it using `manipulation_`. +manipulation_ + :: Manipulation '[] db '[] '[] + -- ^ no input or output + -> Definition db db +manipulation_ = UnsafeDefinition . (<> ";") . renderSQL 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,166 @@ +{- | +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 + , DataKinds + , PolyKinds + , 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 new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Constraint.hs @@ -0,0 +1,352 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Constraint +Description: constraint expressions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +constraint expressions +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Constraint + ( -- * Table Constraints + TableConstraintExpression (..) + , check + , unique + , primaryKey + -- ** Foreign Keys + , foreignKey + , ForeignKeyed + , OnDeleteClause (..) + , OnUpdateClause (..) + , ReferentialAction (..) + ) 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.Expression.Logic +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | Data types are a way to limit the kind of data that can be stored in a +-- table. For many applications, however, the constraint they provide is +-- too coarse. For example, a column containing a product price should +-- probably only accept positive values. But there is no standard data type +-- that accepts only positive numbers. Another issue is that you might want +-- to constrain column data with respect to other columns or rows. +-- For example, in a table containing product information, +-- there should be only one row for each product number. +-- `TableConstraint`s give you as much control over the data in your tables +-- as you wish. If a user attempts to store data in a column that would +-- violate a constraint, an error is raised. This applies +-- even if the value came from the default value definition. +newtype TableConstraintExpression + (sch :: Symbol) + (tab :: Symbol) + (db :: SchemasType) + (constraint :: TableConstraint) + = UnsafeTableConstraintExpression + { renderTableConstraintExpression :: ByteString } + deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL + (TableConstraintExpression sch tab db constraint) where + renderSQL = renderTableConstraintExpression + +{-| A `check` constraint is the most generic `TableConstraint` type. +It allows you to specify that the value in a certain column must satisfy +a Boolean (truth-value) expression. + +>>> :{ +type Schema = '[ + "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[ + "a" ::: 'NoDef :=> 'NotNull 'PGint4, + "b" ::: 'NoDef :=> 'NotNull 'PGint4 + ])] +:} + +>>> :{ +let + definition :: Definition (Public '[]) (Public Schema) + definition = createTable #tab + ( (int & notNullable) `as` #a :* + (int & notNullable) `as` #b ) + ( check (#a :* #b) (#a .> #b) `as` #inequality ) +:} + +>>> printSQL definition +CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); +-} +check + :: ( Has sch db schema + , Has tab schema ('Table table) + , HasAll aliases (TableToRow table) subcolumns ) + => NP Alias aliases + -- ^ specify the subcolumns which are getting checked + -> (forall t. Condition 'Ungrouped '[] '[] db '[] '[t ::: subcolumns]) + -- ^ a closed `Condition` on those subcolumns + -> TableConstraintExpression sch tab db ('Check aliases) +check _cols condition = UnsafeTableConstraintExpression $ + "CHECK" <+> parenthesized (renderSQL condition) + +{-| A `unique` constraint ensure that the data contained in a column, +or a group of columns, is unique among all the rows in the table. + +>>> :{ +type Schema = '[ + "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[ + "a" ::: 'NoDef :=> 'Null 'PGint4, + "b" ::: 'NoDef :=> 'Null 'PGint4 + ])] +:} + +>>> :{ +let + definition :: Definition (Public '[]) (Public Schema) + definition = createTable #tab + ( (int & nullable) `as` #a :* + (int & nullable) `as` #b ) + ( unique (#a :* #b) `as` #uq_a_b ) +:} + +>>> printSQL definition +CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); +-} +unique + :: ( Has sch db schema + , Has tab schema ('Table table) + , HasAll aliases (TableToRow table) subcolumns ) + => NP Alias aliases + -- ^ specify subcolumns which together are unique for each row + -> TableConstraintExpression sch tab db ('Unique aliases) +unique columns = UnsafeTableConstraintExpression $ + "UNIQUE" <+> parenthesized (renderSQL columns) + +{-| A `primaryKey` constraint indicates that a column, or group of columns, +can be used as a unique identifier for rows in the table. +This requires that the values be both unique and not null. + +>>> :{ +type Schema = '[ + "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[ + "id" ::: 'Def :=> 'NotNull 'PGint4, + "name" ::: 'NoDef :=> 'NotNull 'PGtext + ])] +:} + +>>> :{ +let + definition :: Definition (Public '[]) (Public Schema) + definition = createTable #tab + ( serial `as` #id :* + (text & notNullable) `as` #name ) + ( primaryKey #id `as` #pk_id ) +:} + +>>> printSQL definition +CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); +-} +primaryKey + :: ( Has sch db schema + , Has tab schema ('Table table) + , HasAll aliases (TableToColumns table) subcolumns + , AllNotNull subcolumns ) + => NP Alias aliases + -- ^ specify the subcolumns which together form a primary key. + -> TableConstraintExpression sch tab db ('PrimaryKey aliases) +primaryKey columns = UnsafeTableConstraintExpression $ + "PRIMARY KEY" <+> parenthesized (renderSQL columns) + +{-| A `foreignKey` specifies that the values in a column +(or a group of columns) must match the values appearing in some row of +another table. We say this maintains the referential integrity +between two related tables. + +>>> :{ +type Schema = + '[ "users" ::: 'Table ( + '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ]) + , "emails" ::: 'Table ( + '[ "pk_emails" ::: 'PrimaryKey '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ]) + ] +:} + +>>> :{ +let + setup :: Definition (Public '[]) (Public Schema) + setup = + createTable #users + ( serial `as` #id :* + (text & notNullable) `as` #name ) + ( primaryKey #id `as` #pk_users ) >>> + createTable #emails + ( serial `as` #id :* + (int & notNullable) `as` #user_id :* + (text & nullable) `as` #email ) + ( primaryKey #id `as` #pk_emails :* + foreignKey #user_id #users #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")); +CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); + +A `foreignKey` can even be a table self-reference. + +>>> :{ +type Schema = + '[ "employees" ::: 'Table ( + '[ "employees_pk" ::: 'PrimaryKey '["id"] + , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "public" "employees" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + , "employer_id" ::: 'NoDef :=> 'Null 'PGint4 + ]) + ] +:} + +>>> :{ +let + setup :: Definition (Public '[]) (Public Schema) + setup = + createTable #employees + ( serial `as` #id :* + (text & notNullable) `as` #name :* + (integer & nullable) `as` #employer_id ) + ( primaryKey #id `as` #employees_pk :* + foreignKey #employer_id #employees #id + (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 + sch0 sch1 + schema0 schema1 + child parent + table reftable + columns refcolumns + constraints cols + reftys tys ) + => NP Alias columns + -- ^ column or columns in the table + -> QualifiedAlias sch0 parent + -- ^ reference table + -> NP Alias refcolumns + -- ^ reference column or columns in the reference table + -> OnDeleteClause + -- ^ what to do when reference is deleted + -> OnUpdateClause + -- ^ what to do when reference is updated + -> TableConstraintExpression sch1 child db + ('ForeignKey columns sch0 parent refcolumns) +foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ + "FOREIGN KEY" <+> parenthesized (renderSQL keys) + <+> "REFERENCES" <+> renderSQL parent + <+> parenthesized (renderSQL refs) + <+> renderSQL ondel + <+> renderSQL onupd + +-- | A constraint synonym between types involved in a foreign key constraint. +type ForeignKeyed db + sch0 sch1 + schema0 schema1 + child parent + table reftable + columns refcolumns + constraints cols + reftys tys = + ( 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 + , SOP.AllZip SamePGType tys reftys + , Uniquely refcolumns constraints ) + +-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. +newtype OnDeleteClause = OnDelete ReferentialAction + deriving (GHC.Generic,Show,Eq,Ord) +instance NFData OnDeleteClause +instance RenderSQL OnDeleteClause where + renderSQL (OnDelete action) = "ON DELETE" <+> renderSQL action + +-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked +-- when a referenced column is changed (updated). +newtype OnUpdateClause = OnUpdate ReferentialAction + deriving (GHC.Generic,Show,Eq,Ord) +instance NFData 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 + NoAction -> "NO ACTION" + Restrict -> "RESTRICT" + Cascade -> "CASCADE" + SetNull -> "SET NULL" + SetDefault -> "SET DEFAULT" diff --git a/src/Squeal/PostgreSQL/Definition/Function.hs b/src/Squeal/PostgreSQL/Definition/Function.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Function.hs @@ -0,0 +1,250 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Function +Description: create and drop functions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create and drop functions +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Function + ( -- * Create + createFunction + , createOrReplaceFunction + , createSetFunction + , createOrReplaceSetFunction + -- * Drop + , dropFunction + , dropFunctionIfExists + -- * Function Definition + , FunctionDefinition(..) + , languageSqlExpr + , languageSqlQuery + ) 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 +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Query.Values +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | Create a function. + +>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) +>>> :{ +let + definition :: Definition (Public '[]) (Public '["fn" ::: Fn]) + definition = createFunction #fn (int4 *: int4) int4 $ + languageSqlExpr (param @1 * param @2 + 1) +in printSQL definition +:} +CREATE FUNCTION "fn" (int4, int4) RETURNS int4 language sql as $$ SELECT * FROM (VALUES (((($1 :: int4) * ($2 :: int4)) + (1 :: int4)))) AS t ("ret") $$; +-} +createFunction + :: ( Has sch db schema + , KnownSymbol fun + , SOP.SListI args ) + => QualifiedAlias sch fun -- ^ function alias + -> NP (TypeExpression db) args -- ^ arguments + -> TypeExpression db ret -- ^ return type + -> FunctionDefinition db args ('Returns ret) -- ^ function definition + -> Definition db (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) db) +createFunction fun args ret fundef = UnsafeDefinition $ + "CREATE" <+> "FUNCTION" <+> renderSQL fun + <+> parenthesized (renderCommaSeparated renderSQL args) + <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";" + +{- | Create or replace a function. +It is not possible to change the name or argument types +or return type of a function this way. + +>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) +>>> :{ +let + definition :: Definition (Public '["fn" ::: Fn]) (Public '["fn" ::: Fn]) + definition = + createOrReplaceFunction #fn + (int4 *: int4) int4 $ + languageSqlExpr (param @1 @('Null 'PGint4) * param @2 @('Null 'PGint4) + 1) +in printSQL definition +:} +CREATE OR REPLACE FUNCTION "fn" (int4, int4) RETURNS int4 language sql as $$ SELECT * FROM (VALUES (((($1 :: int4) * ($2 :: int4)) + (1 :: int4)))) AS t ("ret") $$; +-} +createOrReplaceFunction + :: ( Has sch db schema + , KnownSymbol fun + , SOP.SListI args ) + => QualifiedAlias sch fun -- ^ function alias + -> NP (TypeExpression db) args -- ^ arguments + -> TypeExpression db ret -- ^ return type + -> FunctionDefinition db args ('Returns ret) -- ^ function definition + -> Definition db (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) db) +createOrReplaceFunction fun args ret fundef = UnsafeDefinition $ + "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun + <+> parenthesized (renderCommaSeparated renderSQL args) + <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";" + +-- | Use a parameterized `Expression` as a function body +languageSqlExpr + :: Expression 'Ungrouped '[] '[] db args '[] ret + -- ^ function body + -> FunctionDefinition db args ('Returns ret) +languageSqlExpr expr = UnsafeFunctionDefinition $ + "language sql as" + <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$" + +-- | Use a parametrized `Query` as a function body +languageSqlQuery + :: Query '[] '[] db args rets + -- ^ function body + -> FunctionDefinition db args ('ReturnsTable rets) +languageSqlQuery qry = UnsafeFunctionDefinition $ + "language sql as" <+> "$$" <+> renderSQL qry <+> "$$" + +{- | Create a set function. + +>>> type Tab = 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]) +>>> type Fn = 'Function ('[ 'Null 'PGint4, 'Null 'PGint4] :=> 'ReturnsTable '["ret" ::: 'Null 'PGint4]) +>>> :{ +let + definition :: Definition (Public '["tab" ::: Tab]) (Public '["tab" ::: Tab, "fn" ::: Fn]) + definition = createSetFunction #fn (int4 *: int4) (int4 `as` #ret) $ + languageSqlQuery (select_ ((param @1 * param @2 + #col) `as` #ret) (from (table #tab))) +in printSQL definition +:} +CREATE FUNCTION "fn" (int4, int4) RETURNS TABLE ("ret" int4) language sql as $$ SELECT ((($1 :: int4) * ($2 :: int4)) + "col") AS "ret" FROM "tab" AS "tab" $$; +-} +createSetFunction + :: ( Has sch db schema + , KnownSymbol fun + , SOP.SListI args + , SOP.SListI rets ) + => QualifiedAlias sch fun -- ^ function alias + -> NP (TypeExpression db) args -- ^ arguments + -> NP (Aliased (TypeExpression db)) rets -- ^ return type + -> FunctionDefinition db args ('ReturnsTable rets) -- ^ function definition + -> Definition db (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) db) +createSetFunction fun args rets fundef = UnsafeDefinition $ + "CREATE" <+> "FUNCTION" <+> renderSQL fun + <+> parenthesized (renderCommaSeparated renderSQL args) + <+> "RETURNS" <+> "TABLE" + <+> parenthesized (renderCommaSeparated renderRet rets) + <+> renderSQL fundef <> ";" + where + renderRet :: Aliased (TypeExpression s) r -> ByteString + renderRet (ty `As` col) = renderSQL col <+> renderSQL ty + +{- | Create or replace a set function. + +>>> type Tab = 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]) +>>> type Fn = 'Function ('[ 'Null 'PGint4, 'Null 'PGint4] :=> 'ReturnsTable '["ret" ::: 'Null 'PGint4]) +>>> :{ +let + definition :: Definition (Public '["tab" ::: Tab, "fn" ::: Fn]) (Public '["tab" ::: Tab, "fn" ::: Fn]) + definition = createOrReplaceSetFunction #fn (int4 *: int4) (int4 `as` #ret) $ + languageSqlQuery (select_ ((param @1 * param @2 + #col) `as` #ret) (from (table #tab))) +in printSQL definition +:} +CREATE OR REPLACE FUNCTION "fn" (int4, int4) RETURNS TABLE ("ret" int4) language sql as $$ SELECT ((($1 :: int4) * ($2 :: int4)) + "col") AS "ret" FROM "tab" AS "tab" $$; +-} +createOrReplaceSetFunction + :: ( Has sch db schema + , KnownSymbol fun + , SOP.SListI args + , SOP.SListI rets ) + => QualifiedAlias sch fun -- ^ function alias + -> NP (TypeExpression db) args -- ^ arguments + -> NP (Aliased (TypeExpression db)) rets -- ^ return type + -> FunctionDefinition db args ('ReturnsTable rets) -- ^ function definition + -> Definition db (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) db) +createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $ + "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun + <+> parenthesized (renderCommaSeparated renderSQL args) + <+> "RETURNS" <+> "TABLE" + <+> parenthesized (renderCommaSeparated renderRet rets) + <+> renderSQL fundef <> ";" + where + renderRet :: Aliased (TypeExpression s) r -> ByteString + renderRet (ty `As` col) = renderSQL col <+> renderSQL ty + +{- | Drop a function. + +>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) +>>> :{ +let + definition :: Definition (Public '["fn" ::: Fn]) (Public '[]) + definition = dropFunction #fn +in printSQL definition +:} +DROP FUNCTION "fn"; +-} +dropFunction + :: (Has sch db schema, KnownSymbol fun) + => QualifiedAlias sch fun + -- ^ function alias + -> Definition db (Alter sch (DropSchemum fun 'Function schema) db) +dropFunction fun = UnsafeDefinition $ + "DROP FUNCTION" <+> renderSQL fun <> ";" + +{- | Drop a function. + +>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) +>>> :{ +let + definition :: Definition (Public '[]) (Public '[]) + definition = dropFunctionIfExists #fn +in printSQL definition +:} +DROP FUNCTION IF EXISTS "fn"; +-} +dropFunctionIfExists + :: (Has sch db schema, KnownSymbol fun) + => QualifiedAlias sch fun + -- ^ function alias + -> Definition db (Alter sch (DropSchemumIfExists fun 'Function schema) db) +dropFunctionIfExists fun = UnsafeDefinition $ + "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";" + +{- | Body of a user defined function-} +newtype FunctionDefinition db args ret = UnsafeFunctionDefinition + { renderFunctionDefinition :: ByteString } + deriving (Eq,Show,GHC.Generic,NFData) +instance RenderSQL (FunctionDefinition db args ret) where + renderSQL = renderFunctionDefinition diff --git a/src/Squeal/PostgreSQL/Definition/Index.hs b/src/Squeal/PostgreSQL/Definition/Index.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Index.hs @@ -0,0 +1,187 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Index +Description: create and drop indexes +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create and drop indexes +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Index + ( -- * Create + createIndex + , createIndexIfNotExists + -- * Drop + , dropIndex + , dropIndexIfExists + -- * Index Method + , IndexMethod (..) + , btree + , hash + , gist + , spgist + , gin + , brin + ) where + +import Data.ByteString +import GHC.TypeLits + +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Expression.Sort +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL +-- >>> :set -XPolyKinds + +{- | Create an index. + +>>> :{ +type Table = '[] :=> + '[ "a" ::: 'NoDef :=> 'Null 'PGint4 + , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] +:} + +>>> :{ +let + setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree]) + setup = + createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>> + createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast] +in printSQL setup +:} +CREATE TABLE "tab" ("a" int NULL, "b" real NULL); +CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST); +-} +createIndex + :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix) + => Alias ix -- ^ index alias + -> QualifiedAlias sch tab -- ^ table alias + -> IndexMethod method -- ^ index method + -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]] + -- ^ sorted columns + -> Definition db (Alter sch (Create ix ('Index method) schema) db) +createIndex ix tab method cols = UnsafeDefinition $ + "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab + <+> "USING" <+> renderSQL method + <+> parenthesized (commaSeparated (renderIndex <$> cols)) + <> ";" + where + renderIndex = \case + Asc expression -> parenthesized (renderSQL expression) <+> "ASC" + Desc expression -> parenthesized (renderSQL expression) <+> "DESC" + AscNullsFirst expression -> parenthesized (renderSQL expression) + <+> "ASC NULLS FIRST" + DescNullsFirst expression -> parenthesized (renderSQL expression) + <+> "DESC NULLS FIRST" + AscNullsLast expression -> parenthesized (renderSQL expression) + <+> "ASC NULLS LAST" + DescNullsLast expression -> parenthesized (renderSQL expression) + <+> "DESC NULLS LAST" + +-- | Create an index if it doesn't exist. +createIndexIfNotExists + :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix) + => Alias ix -- ^ index alias + -> QualifiedAlias sch tab -- ^ table alias + -> IndexMethod method -- ^ index method + -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]] + -- ^ sorted columns + -> Definition db (Alter sch (CreateIfNotExists ix ('Index method) schema) db) +createIndexIfNotExists ix tab method cols = UnsafeDefinition $ + "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab + <+> "USING" <+> renderSQL method + <+> parenthesized (commaSeparated (renderIndex <$> cols)) + <> ";" + where + renderIndex = \case + Asc expression -> parenthesized (renderSQL expression) <+> "ASC" + Desc expression -> parenthesized (renderSQL expression) <+> "DESC" + AscNullsFirst expression -> parenthesized (renderSQL expression) + <+> "ASC NULLS FIRST" + DescNullsFirst expression -> parenthesized (renderSQL expression) + <+> "DESC NULLS FIRST" + AscNullsLast expression -> parenthesized (renderSQL expression) + <+> "ASC NULLS LAST" + DescNullsLast expression -> parenthesized (renderSQL expression) + <+> "DESC NULLS LAST" + +{- | +PostgreSQL provides several index types: +B-tree, Hash, GiST, SP-GiST, GIN and BRIN. +Each index type uses a different algorithm +that is best suited to different types of queries. +-} +newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString} + deriving stock (Eq, Ord, Show, GHC.Generic) +instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod +-- | B-trees can handle equality and range queries on data +-- that can be sorted into some ordering. +btree :: IndexMethod 'Btree +btree = UnsafeIndexMethod "btree" +-- | Hash indexes can only handle simple equality comparisons. +hash :: IndexMethod 'Hash +hash = UnsafeIndexMethod "hash" +-- | GiST indexes are not a single kind of index, +-- but rather an infrastructure within which many different +-- indexing strategies can be implemented. +gist :: IndexMethod 'Gist +gist = UnsafeIndexMethod "gist" +-- | SP-GiST indexes, like GiST indexes, +-- offer an infrastructure that supports various kinds of searches. +spgist :: IndexMethod 'Spgist +spgist = UnsafeIndexMethod "spgist" +-- | GIN indexes are “inverted indexes” which are appropriate for +-- data values that contain multiple component values, such as arrays. +gin :: IndexMethod 'Gin +gin = UnsafeIndexMethod "gin" +-- | BRIN indexes (a shorthand for Block Range INdexes) store summaries +-- about the values stored in consecutive physical block ranges of a table. +brin :: IndexMethod 'Brin +brin = UnsafeIndexMethod "brin" + +-- | Drop an index. +-- +-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[])) +-- DROP INDEX "ix"; +dropIndex + :: (Has sch db schema, KnownSymbol ix) + => QualifiedAlias sch ix -- ^ index alias + -> Definition db (Alter sch (DropSchemum ix 'Index schema) db) +dropIndex ix = UnsafeDefinition $ "DROP INDEX" <+> renderSQL ix <> ";" + +-- | Drop an index if it exists. +dropIndexIfExists + :: (Has sch db schema, KnownSymbol ix) + => QualifiedAlias sch ix -- ^ index alias + -> Definition db (Alter sch (DropSchemumIfExists ix 'Index schema) db) +dropIndexIfExists ix = UnsafeDefinition $ + "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";" diff --git a/src/Squeal/PostgreSQL/Definition/Procedure.hs b/src/Squeal/PostgreSQL/Definition/Procedure.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Procedure.hs @@ -0,0 +1,172 @@ +{-| +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 + , DataKinds + , PolyKinds + , 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/Schema.hs b/src/Squeal/PostgreSQL/Definition/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Schema.hs @@ -0,0 +1,114 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Schema +Description: create and drop schemas +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create and drop schemas +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Schema + ( -- * Create + createSchema + , createSchemaIfNotExists + -- * Drop + , dropSchemaCascade + , dropSchemaCascadeIfExists + ) where + +import GHC.TypeLits + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | +`createSchema` enters a new schema into the current database. +The schema name must be distinct from the name of any existing schema +in the current database. + +A schema is essentially a namespace: it contains named objects +(tables, data types, functions, and operators) whose names +can duplicate those of other objects existing in other schemas. +Named objects are accessed by `QualifiedAlias`es with the schema +name as a prefix. + +>>> :{ +let + definition :: Definition '["public" ::: '[]] '["public" ::: '[], "my_schema" ::: '[]] + definition = createSchema #my_schema +in printSQL definition +:} +CREATE SCHEMA "my_schema"; +-} +createSchema + :: KnownSymbol sch + => Alias sch -- ^ schema alias + -> Definition db (Create sch '[] db) +createSchema sch = UnsafeDefinition $ + "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";" + +{- | Create a schema if it does not yet exist.-} +createSchemaIfNotExists + :: (KnownSymbol sch, Has sch db schema) + => Alias sch -- ^ schema alias + -> Definition db (CreateIfNotExists sch '[] db) +createSchemaIfNotExists sch = UnsafeDefinition $ + "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS" + <+> renderSQL sch <> ";" + +-- | Drop a schema. +-- Automatically drop objects (tables, functions, etc.) +-- that are contained in the schema. +-- +-- >>> :{ +-- let +-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public] +-- definition = dropSchemaCascade #muh_schema +-- :} +-- +-- >>> printSQL definition +-- DROP SCHEMA "muh_schema" CASCADE; +dropSchemaCascade + :: KnownSymbol sch + => Alias sch -- ^ schema alias + -> Definition db (Drop sch db) +dropSchemaCascade sch = UnsafeDefinition $ + "DROP SCHEMA" <+> renderSQL sch <+> "CASCADE;" + +-- | Drop a schema if it exists. +-- Automatically drop objects (tables, functions, etc.) +-- that are contained in the schema. +dropSchemaCascadeIfExists + :: KnownSymbol sch + => Alias sch -- ^ schema alias + -> Definition db (DropIfExists sch db) +dropSchemaCascadeIfExists sch = UnsafeDefinition $ + "DROP SCHEMA IF EXISTS" <+> renderSQL sch <+> "CASCADE;" diff --git a/src/Squeal/PostgreSQL/Definition/Table.hs b/src/Squeal/PostgreSQL/Definition/Table.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Table.hs @@ -0,0 +1,537 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Table +Description: create, drop and alter tables +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create, drop and alter tables +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Table + ( -- * Create + createTable + , createTableIfNotExists + -- * Drop + , dropTable + , dropTableIfExists + -- * Alter + , alterTable + , alterTableIfExists + , alterTableRename + , alterTableIfExistsRename + , alterTableSetSchema + , AlterTable (..) + -- ** Constraints + , addConstraint + , dropConstraint + -- ** Columns + , AddColumn (..) + , dropColumn + , renameColumn + , alterColumn + , AlterColumn (..) + , setDefault + , dropDefault + , setNotNull + , dropNotNull + , alterType + ) 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.Definition.Constraint +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | `createTable` adds a table to the schema. + +>>> :set -XOverloadedLabels +>>> :{ +type Table = '[] :=> + '[ "a" ::: 'NoDef :=> 'Null 'PGint4 + , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] +:} + +>>> :{ +let + setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table]) + setup = createTable #tab + (nullable int `as` #a :* nullable real `as` #b) Nil +in printSQL setup +:} +CREATE TABLE "tab" ("a" int NULL, "b" real NULL); +-} +createTable + :: ( KnownSymbol sch + , KnownSymbol tab + , columns ~ (col ': cols) + , SOP.SListI columns + , SOP.SListI constraints + , Has sch db0 schema0 + , db1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) db0 ) + => QualifiedAlias sch tab -- ^ the name of the table to add + -> NP (Aliased (ColumnTypeExpression db0)) columns + -- ^ the names and datatype of each column + -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints + -- ^ constraints that must hold for the table + -> Definition db0 db1 +createTable tab columns constraints = UnsafeDefinition $ + "CREATE TABLE" <+> renderCreation tab columns constraints + +{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. +Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. +`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in +the `Control.Category.Category` of `Definition`s. + +>>> :set -XOverloadedLabels -XTypeApplications +>>> :{ +type Table = '[] :=> + '[ "a" ::: 'NoDef :=> 'Null 'PGint4 + , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] +:} + +>>> type Schemas = Public '["tab" ::: 'Table Table] + +>>> :{ +let + setup :: Definition Schemas Schemas + setup = createTableIfNotExists #tab + (nullable int `as` #a :* nullable real `as` #b) Nil +in printSQL setup +:} +CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); +-} +createTableIfNotExists + :: ( KnownSymbol sch + , KnownSymbol tab + , columns ~ (col ': cols) + , SOP.SListI columns + , SOP.SListI constraints + , Has sch db0 schema0 + , db1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) db0 ) + => QualifiedAlias sch tab -- ^ the name of the table to add + -> NP (Aliased (ColumnTypeExpression db0)) columns + -- ^ the names and datatype of each column + -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints + -- ^ constraints that must hold for the table + -> Definition db0 db1 +createTableIfNotExists tab columns constraints = UnsafeDefinition $ + "CREATE TABLE IF NOT EXISTS" + <+> renderCreation tab columns constraints + +-- helper function for `createTable` and `createTableIfNotExists` +renderCreation + :: ( KnownSymbol sch + , KnownSymbol tab + , SOP.SListI columns + , SOP.SListI constraints ) + => QualifiedAlias sch tab -- ^ the name of the table to add + -> NP (Aliased (ColumnTypeExpression db0)) columns + -- ^ the names and datatype of each column + -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints + -- ^ constraints that must hold for the table + -> ByteString +renderCreation tab columns constraints = renderSQL tab + <+> parenthesized + ( renderCommaSeparated renderColumnDef columns + <> ( case constraints of + Nil -> "" + _ -> ", " <> + renderCommaSeparated renderConstraint constraints ) ) + <> ";" + where + renderColumnDef :: Aliased (ColumnTypeExpression db) x -> ByteString + renderColumnDef (ty `As` column) = + renderSQL column <+> renderColumnTypeExpression ty + renderConstraint + :: Aliased (TableConstraintExpression sch tab db) constraint + -> ByteString + renderConstraint (constraint `As` alias) = + "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint + +-- | `dropTable` removes a table from the schema. +-- +-- >>> :{ +-- let +-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[]) +-- definition = dropTable #muh_table +-- :} +-- +-- >>> printSQL definition +-- DROP TABLE "muh_table"; +dropTable + :: ( Has sch db schema + , KnownSymbol tab ) + => QualifiedAlias sch tab -- ^ table to remove + -> Definition db (Alter sch (DropSchemum tab 'Table schema) db) +dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";" + +-- | Drop a table if it exists. +dropTableIfExists + :: ( Has sch db schema + , KnownSymbol tab) + => QualifiedAlias sch tab -- ^ table to remove + -> Definition db (Alter sch (DropSchemumIfExists tab 'Table schema) db) +dropTableIfExists tab = UnsafeDefinition $ + "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";" + +-- | `alterTable` changes the definition of a table from the schema. +alterTable + :: (Has sch db schema, KnownSymbol tab) + => QualifiedAlias sch tab -- ^ table to alter + -> AlterTable sch tab db table -- ^ alteration to perform + -> Definition db (Alter sch (Alter tab ('Table table) schema) db) +alterTable tab alteration = UnsafeDefinition $ + "ALTER TABLE" + <+> renderSQL tab + <+> renderAlterTable alteration + <> ";" + +-- | `alterTable` changes the definition of a table from the schema. +alterTableIfExists + :: (Has sch db schema, KnownSymbol tab) + => QualifiedAlias sch tab -- ^ table to alter + -> AlterTable sch tab db table -- ^ alteration to perform + -> Definition db (Alter sch (AlterIfExists tab ('Table table) schema) db) +alterTableIfExists tab alteration = UnsafeDefinition $ + "ALTER TABLE IF EXISTS" + <+> renderSQL tab + <+> renderAlterTable alteration + <> ";" + +-- | `alterTableRename` changes the name of a table from the schema. +-- +-- >>> 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 + :: ( Has sch db schema + , KnownSymbol tab1 + , Has tab0 schema ('Table table)) + => QualifiedAlias sch tab0 -- ^ table to rename + -> Alias tab1 -- ^ what to rename it + -> Definition db (Alter sch (Rename tab0 tab1 schema) db ) +alterTableRename tab0 tab1 = UnsafeDefinition $ + "ALTER TABLE" <+> renderSQL tab0 + <+> "RENAME TO" <+> renderSQL tab1 <> ";" + +-- | `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 + :: ( Has sch db schema + , KnownSymbol tab0 + , KnownSymbol tab1 ) + => QualifiedAlias sch tab0 -- ^ table to rename + -> Alias tab1 -- ^ what to rename it + -> 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. +newtype AlterTable + (sch :: Symbol) + (tab :: Symbol) + (db :: SchemasType) + (table :: TableType) = + UnsafeAlterTable {renderAlterTable :: ByteString} + deriving (GHC.Generic,Show,Eq,Ord,NFData) + +-- | An `addConstraint` adds a table constraint. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0))) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > (0 :: int4))); +addConstraint + :: ( KnownSymbol alias + , Has sch db schema + , Has tab schema ('Table (constraints :=> columns)) ) + => Alias alias + -> TableConstraintExpression sch tab db constraint + -- ^ constraint to add + -> AlterTable sch tab db (Create alias constraint constraints :=> columns) +addConstraint alias constraint = UnsafeAlterTable $ + "ADD" <+> "CONSTRAINT" <+> renderSQL alias + <+> renderSQL constraint + +-- | A `dropConstraint` drops a table constraint. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- definition = alterTable #tab (dropConstraint #positive) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" DROP CONSTRAINT "positive"; +dropConstraint + :: ( KnownSymbol constraint + , Has sch db schema + , Has tab schema ('Table (constraints :=> columns)) ) + => Alias constraint + -- ^ constraint to drop + -> AlterTable sch tab db (Drop constraint constraints :=> columns) +dropConstraint constraint = UnsafeAlterTable $ + "DROP" <+> "CONSTRAINT" <+> renderSQL constraint + +-- | An `AddColumn` is either @NULL@ or has @DEFAULT@. +class AddColumn ty where + -- | `addColumn` adds a new column, initially filled with whatever + -- default value is given or with @NULL@. + -- + -- >>> :{ + -- let + -- definition :: Definition + -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] + -- '["public" ::: '["tab" ::: 'Table ('[] :=> + -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 + -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]] + -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) + -- in printSQL definition + -- :} + -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT (E'foo' :: text); + -- + -- >>> :{ + -- let + -- definition :: Definition + -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] + -- '["public" ::: '["tab" ::: 'Table ('[] :=> + -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 + -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] + -- definition = alterTable #tab (addColumn #col2 (text & nullable)) + -- in printSQL definition + -- :} + -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; + addColumn + :: ( KnownSymbol column + , Has sch db schema + , Has tab schema ('Table (constraints :=> columns)) ) + => Alias column -- ^ column to add + -> ColumnTypeExpression db ty -- ^ type of the new column + -> AlterTable sch tab db (constraints :=> Create column ty columns) + addColumn column ty = UnsafeAlterTable $ + "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty +instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) +instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) + +-- | A `dropColumn` removes a column. Whatever data was in the column +-- disappears. Table constraints involving the column are dropped, too. +-- However, if the column is referenced by a foreign key constraint of +-- another table, PostgreSQL will not silently drop that constraint. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> +-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 +-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] +-- definition = alterTable #tab (dropColumn #col2) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" DROP COLUMN "col2"; +dropColumn + :: ( KnownSymbol column + , Has sch db schema + , Has tab schema ('Table (constraints :=> columns)) ) + => Alias column -- ^ column to remove + -> AlterTable sch tab db (constraints :=> Drop column columns) +dropColumn column = UnsafeAlterTable $ + "DROP COLUMN" <+> renderSQL column + +-- | A `renameColumn` renames a column. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]] +-- definition = alterTable #tab (renameColumn #foo #bar) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar"; +renameColumn + :: ( KnownSymbol column0 + , KnownSymbol column1 + , Has sch db schema + , Has tab schema ('Table (constraints :=> columns)) ) + => Alias column0 -- ^ column to rename + -> Alias column1 -- ^ what to rename the column + -> AlterTable sch tab db (constraints :=> Rename column0 column1 columns) +renameColumn column0 column1 = UnsafeAlterTable $ + "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1 + +-- | An `alterColumn` alters a single column. +alterColumn + :: ( KnownSymbol column + , Has sch db schema + , Has tab schema ('Table (constraints :=> columns)) + , Has column columns ty0 ) + => Alias column -- ^ column to alter + -> AlterColumn db ty0 ty1 -- ^ alteration to perform + -> AlterTable sch tab db (constraints :=> Alter column ty1 columns) +alterColumn column alteration = UnsafeAlterTable $ + "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration + +-- | An `AlterColumn` describes the alteration to perform on a single column. +newtype AlterColumn (db :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) = + UnsafeAlterColumn {renderAlterColumn :: ByteString} + deriving (GHC.Generic,Show,Eq,Ord,NFData) + +-- | A `setDefault` sets a new default for a column. Note that this doesn't +-- affect any existing rows in the table, it just changes the default for +-- future insert and update commands. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] +-- definition = alterTable #tab (alterColumn #col (setDefault 5)) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT (5 :: int4); +setDefault + :: Expression 'Ungrouped '[] '[] db '[] '[] ty -- ^ default value to set + -> AlterColumn db (constraint :=> ty) ('Def :=> ty) +setDefault expression = UnsafeAlterColumn $ + "SET DEFAULT" <+> renderExpression expression + +-- | A `dropDefault` removes any default value for a column. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] +-- definition = alterTable #tab (alterColumn #col dropDefault) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT; +dropDefault :: AlterColumn db ('Def :=> ty) ('NoDef :=> ty) +dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" + +-- | A `setNotNull` adds a @NOT NULL@ constraint to a column. +-- The constraint will be checked immediately, so the table data must satisfy +-- the constraint before it can be added. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- definition = alterTable #tab (alterColumn #col setNotNull) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; +setNotNull + :: AlterColumn db (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) +setNotNull = UnsafeAlterColumn $ "SET NOT NULL" + +-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] +-- definition = alterTable #tab (alterColumn #col dropNotNull) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; +dropNotNull + :: AlterColumn db (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) +dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" + +-- | An `alterType` converts a column to a different data type. +-- This will succeed only if each existing entry in the column can be +-- converted to the new type by an implicit cast. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] +-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]] +-- definition = +-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) +-- in printSQL definition +-- :} +-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL; +alterType :: ColumnTypeExpression db ty -> AlterColumn db ty0 ty +alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty diff --git a/src/Squeal/PostgreSQL/Definition/Type.hs b/src/Squeal/PostgreSQL/Definition/Type.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/Type.hs @@ -0,0 +1,292 @@ +{-| +Module: Squeal.PostgreSQL.Definition.Type +Description: create and drop types +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create and drop types +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.Type + ( -- * Create + createTypeEnum + , createTypeEnumFrom + , createTypeComposite + , createTypeCompositeFrom + , createTypeRange + , createDomain + -- * Drop + , dropType + , dropTypeIfExists + -- * Alter + , alterTypeRename + , alterTypeSetSchema + ) where + +import Data.ByteString +import Data.Monoid +import GHC.TypeLits +import Prelude hiding ((.), id) + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.PG +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL +-- >>> import qualified GHC.Generics as GHC +-- >>> import qualified Generics.SOP as SOP + +-- | Enumerated types are created using the `createTypeEnum` command, for example +-- +-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]]) +-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); +createTypeEnum + :: (KnownSymbol enum, Has sch db schema, SOP.All KnownSymbol labels) + => QualifiedAlias sch enum + -- ^ name of the user defined enumerated type + -> NP PGlabel labels + -- ^ labels of the enumerated type + -> Definition db (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) db) +createTypeEnum enum labels = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+> + parenthesized (renderSQL labels) <> ";" + +-- | Enumerated types can also be generated from a Haskell type, for example +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance SOP.Generic Schwarma +-- >>> instance SOP.HasDatatypeInfo Schwarma +-- >>> :{ +-- let +-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] +-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma +-- in +-- printSQL createSchwarma +-- :} +-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); +createTypeEnumFrom + :: forall hask sch enum db schema. + ( SOP.Generic hask + , SOP.All KnownSymbol (LabelsPG hask) + , KnownSymbol enum + , Has sch db schema ) + => QualifiedAlias sch enum + -- ^ name of the user defined enumerated type + -> Definition db (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) db) +createTypeEnumFrom enum = createTypeEnum enum + (SOP.hpure label :: NP PGlabel (LabelsPG hask)) + +{- | `createTypeComposite` creates a composite type. The composite type is +specified by a list of attribute names and data types. + +>>> :{ +type PGcomplex = 'PGcomposite + '[ "real" ::: 'NotNull 'PGfloat8 + , "imaginary" ::: 'NotNull 'PGfloat8 ] +:} + +>>> :{ +let + setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]] + setup = createTypeComposite #complex + (float8 `as` #real :* float8 `as` #imaginary) +in printSQL setup +:} +CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); +-} +createTypeComposite + :: (KnownSymbol ty, Has sch db schema, SOP.SListI fields) + => QualifiedAlias sch ty + -- ^ name of the user defined composite type + -> NP (Aliased (TypeExpression db)) fields + -- ^ list of attribute names and data types + -> Definition db (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) db) +createTypeComposite ty fields = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized + (renderCommaSeparated renderField fields) <> ";" + where + renderField :: Aliased (TypeExpression db) x -> ByteString + renderField (typ `As` alias) = + renderSQL alias <+> renderSQL typ + +-- | Composite types can also be generated from a Haskell type, for example +-- +-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic +-- >>> instance SOP.Generic Complex +-- >>> instance SOP.HasDatatypeInfo Complex +-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))] +-- >>> :{ +-- let +-- createComplex :: Definition (Public '[]) (Public Schema) +-- createComplex = createTypeCompositeFrom @Complex #complex +-- in +-- printSQL createComplex +-- :} +-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); +createTypeCompositeFrom + :: forall hask sch ty db schema. + ( SOP.All (FieldTyped db) (RowPG hask) + , KnownSymbol ty + , Has sch db schema ) + => QualifiedAlias sch ty + -- ^ name of the user defined composite type + -> Definition db (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) db) +createTypeCompositeFrom ty = createTypeComposite ty + (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped db)) fieldtype + :: NP (Aliased (TypeExpression db)) (RowPG hask)) + +{-| +`createDomain` creates a new domain. A domain is essentially a data type +with constraints (restrictions on the allowed set of values). + +Domains are useful for abstracting common constraints on fields +into a single location for maintenance. For example, several tables might +contain email address columns, all requiring the same +`Squeal.PostgreSQL.Definition.Table.Constraint.check` constraint +to verify the address syntax. Define a domain rather than setting up +each table's constraint individually. + +>>> :{ +let + createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4]) + createPositive = createDomain #positive real (#value .> 0) +in printSQL createPositive +:} +CREATE DOMAIN "positive" AS real CHECK (("value" > (0.0 :: float4))); +-} +createDomain + :: (Has sch db schema, KnownSymbol dom) + => QualifiedAlias sch dom -- ^ domain alias + -> (forall null. TypeExpression db (null ty)) -- ^ underlying type + -> (forall tab. Condition 'Ungrouped '[] '[] db '[] '[tab ::: '["value" ::: 'Null ty]]) + -- ^ constraint on type + -> Definition db (Alter sch (Create dom ('Typedef ty) schema) db) +createDomain dom ty condition = + UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom + <+> "AS" <+> renderTypeExpression ty + <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";" + +{- | Range types are data types representing a range of values +of some element type (called the range's subtype). +The subtype must have a total order so that it is well-defined +whether element values are within, before, or after a range of values. + +Range types are useful because they represent many element values +in a single range value, and because concepts such as overlapping ranges +can be expressed clearly. +The use of time and date ranges for scheduling purposes +is the clearest example; but price ranges, +measurement ranges from an instrument, and so forth can also be useful. + +>>> :{ +let + createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)]) + createSmallIntRange = createTypeRange #int2range int2 +in printSQL createSmallIntRange +:} +CREATE TYPE "int2range" AS RANGE (subtype = int2); +-} +createTypeRange + :: (Has sch db schema, KnownSymbol range) + => QualifiedAlias sch range -- ^ range alias + -> (forall null. TypeExpression db (null ty)) -- ^ underlying type + -> Definition db (Alter sch (Create range ('Typedef ('PGrange ty)) schema) db) +createTypeRange range ty = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+> + parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";" + +-- | Drop a type. +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance SOP.Generic Schwarma +-- >>> instance SOP.HasDatatypeInfo Schwarma +-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[])) +-- DROP TYPE "schwarma"; +dropType + :: (Has sch db schema, KnownSymbol td) + => QualifiedAlias sch td + -- ^ name of the user defined type + -> Definition db (Alter sch (DropSchemum td 'Typedef schema) db) +dropType tydef = UnsafeDefinition $ "DROP TYPE" <+> renderSQL tydef <> ";" + +-- | Drop a type if it exists. +dropTypeIfExists + :: (Has sch db schema, KnownSymbol td) + => QualifiedAlias sch td + -- ^ name of the user defined type + -> 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 new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Definition/View.hs @@ -0,0 +1,180 @@ +{-| +Module: Squeal.PostgreSQL.Definition.View +Description: create and drop views +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +create and drop views +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Definition.View + ( -- * Create + createView + , createOrReplaceView + -- * Drop + , dropView + , dropViewIfExists + -- * Alter + , alterViewRename + , alterViewSetSchema + ) where + +import GHC.TypeLits + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | Create a view. + +>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] +>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] +>>> :{ +let + definition :: Definition + '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] + '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] + definition = + createView #bc (select_ (#b :* #c) (from (table #abc))) +in printSQL definition +:} +CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; +-} +createView + :: (Has sch db schema, KnownSymbol vw) + => QualifiedAlias sch vw -- ^ the name of the view to add + -> Query '[] '[] db '[] view -- ^ query + -> Definition db (Alter sch (Create vw ('View view) schema) db) +createView alias query = UnsafeDefinition $ + "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS" + <+> renderQuery query <> ";" + +{- | Create or replace a view. + +>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] +>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] +>>> :{ +let + definition :: Definition + '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] + '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] + definition = + createOrReplaceView #bc (select_ (#b :* #c) (from (table #abc))) +in printSQL definition +:} +CREATE OR REPLACE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; +-} +createOrReplaceView + :: (Has sch db schema, KnownSymbol vw) + => QualifiedAlias sch vw -- ^ the name of the view to add + -> Query '[] '[] db '[] view -- ^ query + -> Definition db (Alter sch (CreateOrReplace vw ('View view) schema) db) +createOrReplaceView alias query = UnsafeDefinition $ + "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS" + <+> renderQuery query <> ";" + +-- | Drop a view. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) +-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] +-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] +-- definition = dropView #bc +-- in printSQL definition +-- :} +-- DROP VIEW "bc"; +dropView + :: (Has sch db schema, KnownSymbol vw) + => QualifiedAlias sch vw -- ^ view to remove + -> Definition db (Alter sch (DropSchemum vw 'View schema) db) +dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";" + +-- | Drop a view if it exists. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) +-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] +-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] +-- definition = dropViewIfExists #bc +-- in printSQL definition +-- :} +-- DROP VIEW IF EXISTS "bc"; +dropViewIfExists + :: (Has sch db schema, KnownSymbol vw) + => QualifiedAlias sch vw -- ^ view to remove + -> 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 @@ -1,17 +1,18 @@ {-| Module: Squeal.PostgreSQL.Expression -Description: Squeal expressions +Description: expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Squeal expressions are the atoms used to build statements. +Expressions are the atoms used to build statements. -} {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds , DeriveGeneric + , DerivingStrategies , FlexibleContexts , FlexibleInstances , FunctionalDependencies @@ -24,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances , RankNTypes @@ -34,26 +36,37 @@ ( -- * Expression Expression (..) , Expr - , (:-->) + -- * Function + , type (-->) + , Fun , unsafeFunction - , unsafeUnaryOpL - , unsafeUnaryOpR + , function + , unsafeLeftOp + , unsafeRightOp + -- * Operator , Operator + , OperatorDB , unsafeBinaryOp + , PGSubset (..) + , PGIntersect (..) + -- * Multivariable Function , FunctionVar , unsafeFunctionVar - , FunctionN + , type (--->) + , FunN , unsafeFunctionN - , PGSubset (..) + , functionN -- * Re-export , (&) - , K (..) - , unK ) where import Control.Category import Control.DeepSeq +import Data.Binary.Builder (toLazyByteString) import Data.ByteString (ByteString) +import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec) +import Data.ByteString.Builder.Scientific (scientificBuilder) +import Data.ByteString.Lazy (toStrict) import Data.Function ((&)) import Data.Semigroup hiding (All) import Data.String @@ -65,10 +78,10 @@ import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.List +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -80,9 +93,10 @@ {- | `Expression`s are used in a variety of contexts, such as in the target `Squeal.PostgreSQL.Query.List` of the `Squeal.PostgreSQL.Query.select` command, -as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or +as new column values in `Squeal.PostgreSQL.Manipulation.insertInto` or `Squeal.PostgreSQL.Manipulation.update`, -or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands. +or in search `Squeal.PostgreSQL.Expression.Logic.Condition`s +in a number of commands. The expression syntax allows the calculation of values from primitive expression using arithmetic, logical, @@ -90,29 +104,30 @@ The type parameters of `Expression` are -* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which +* @lat :: @ `FromType`, the @from@ clauses of any lat queries in which the `Expression` is a correlated subquery expression; -* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s +* @with :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s that are in scope for the `Expression`; * @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit which columns may be referenced by alias; -* @schemas :: @ `SchemasType`, the schemas of your database that are in +* @db :: @ `SchemasType`, the schemas of your database that are in scope for the `Expression`; * @from :: @ `FromType`, the @from@ clause which the `Expression` may use to reference columns by alias; -* @ty :: @ `NullityType`, the type of the `Expression`. +* @ty :: @ `NullType`, the type of the `Expression`. -} newtype Expression - (outer :: FromType) - (commons :: FromType) (grp :: Grouping) - (schemas :: SchemasType) - (params :: [NullityType]) + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) (from :: FromType) - (ty :: NullityType) + (ty :: NullType) = UnsafeExpression { renderExpression :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (Expression outer commons grp schemas params from ty) where + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (Expression grp lat with db params from ty) where renderSQL = renderExpression -- | An `Expr` is a closed `Expression`. @@ -122,18 +137,21 @@ -- or alias references. It can be used as -- a simple piece of more complex `Expression`s. type Expr x - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x + = forall grp lat with db params from + . Expression grp lat with db params from x -- ^ cannot reference aliases -- | A @RankNType@ for binary operators. -type Operator x1 x2 y - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x1 +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 + = forall grp lat with params from + . Expression grp lat with db params from x1 -- ^ left input - -> Expression outer commons grp schemas params from x2 + -> Expression grp lat with db params from x2 -- ^ right input - -> Expression outer commons grp schemas params from y + -> Expression grp lat with db params from y -- ^ output -- | A @RankNType@ for functions with a single argument. @@ -141,11 +159,14 @@ -- This is a subtype of the usual Haskell function type `Prelude.->`, -- indeed a subcategory as it is closed under the usual -- `Prelude..` and `Prelude.id`. -type (:-->) x y - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x +type (-->) x y = forall db. Fun db x y + +-- | Like `-->` but depends on the schemas of the database +type Fun db x y + = forall grp lat with params from + . Expression grp lat with db params from x -- ^ input - -> Expression outer commons grp schemas params from y + -> Expression grp lat with db params from y -- ^ output {- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments. @@ -154,23 +175,26 @@ >>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true)) fun(TRUE, FALSE, LOCALTIME, TRUE) -} -type FunctionN xs y - = forall outer commons grp schemas params from - . NP (Expression outer commons grp schemas params from) xs +type (--->) xs y = forall db. FunN db xs y + +-- | Like `--->` but depends on the schemas of the database +type FunN db xs y + = forall grp lat with params from + . NP (Expression grp lat with db params from) xs -- ^ inputs - -> Expression outer commons grp schemas params from y + -> Expression grp lat with db params from y -- ^ output {- | A @RankNType@ for functions with a variable-length list of homogeneous arguments and at least 1 more argument. -} type FunctionVar x0 x1 y - = forall outer commons grp schemas params from - . [Expression outer commons grp schemas params from x0] + = forall grp lat with db params from + . [Expression grp lat with db params from x0] -- ^ inputs - -> Expression outer commons grp schemas params from x1 + -> Expression grp lat with db params from x1 -- ^ must have at least 1 input - -> Expression outer commons grp schemas params from y + -> Expression grp lat with db params from y -- ^ output {- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false) @@ -180,104 +204,104 @@ unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x) -instance (HasUnique tab (Join outer from) row, Has col row ty) - => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where +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 outer from) row, Has col row ty, tys ~ '[ty]) - => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where +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 outer 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 outer commons 'Ungrouped schemas params from) column) where + (Aliased (Expression 'Ungrouped lat with db params from) column) where fromLabel = fromLabel @col `As` Alias -instance (HasUnique tab (Join outer 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 outer commons 'Ungrouped schemas params from)) columns) where + (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where fromLabel = fromLabel @col :* Nil -instance (Has tab (Join outer from) row, Has col row ty) - => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where +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 outer from) row, Has col row ty, tys ~ '[ty]) - => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where +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 outer 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 outer commons 'Ungrouped schemas params from) column) where + (Aliased (Expression 'Ungrouped lat with db params from) column) where tab ! col = tab ! col `As` col -instance (Has tab (Join outer 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 outer commons 'Ungrouped schemas params from)) columns) where + (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where tab ! col = tab ! col :* Nil instance - ( HasUnique tab (Join outer from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsLabel col - (Expression outer commons ('Grouped bys) schemas params from ty) where + (Expression ('Grouped bys) lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col) instance - ( HasUnique tab (Join outer from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty] ) => IsLabel col - (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where + (NP (Expression ('Grouped bys) lat with db params from) tys) where fromLabel = fromLabel @col :* Nil instance - ( HasUnique tab (Join outer from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty) ) => IsLabel col - (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where + (Aliased (Expression ('Grouped bys) lat with db params from) column) where fromLabel = fromLabel @col `As` Alias instance - ( HasUnique tab (Join outer from) row + ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty] ) => IsLabel col - (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where + (NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where fromLabel = fromLabel @col :* Nil instance - ( Has tab (Join outer from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsQualified tab col - (Expression outer commons ('Grouped bys) schemas params from ty) where + (Expression ('Grouped bys) lat with db params from ty) where tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col instance - ( Has tab (Join outer from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty] ) => IsQualified tab col - (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where + (NP (Expression ('Grouped bys) lat with db params from) tys) where tab ! col = tab ! col :* Nil instance - ( Has tab (Join outer from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty) ) => IsQualified tab col - (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where + (Aliased (Expression ('Grouped bys) lat with db params from) column) where tab ! col = tab ! col `As` col instance - ( Has tab (Join outer from) row + ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty] ) => IsQualified tab col - (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where + (NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where tab ! col = tab ! col :* Nil instance (KnownSymbol label, label `In` labels) => IsPGlabel label - (Expression outer commons grp schemas params from (null ('PGenum labels))) where + (Expression grp lat with db params from (null ('PGenum labels))) where label = UnsafeExpression $ renderSQL (PGlabel @label) -- | >>> printSQL $ unsafeBinaryOp "OR" true false @@ -286,30 +310,70 @@ unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ renderSQL x <+> op <+> renderSQL y --- | >>> printSQL $ unsafeUnaryOpL "NOT" true +-- | >>> printSQL $ unsafeLeftOp "NOT" true -- (NOT TRUE) -unsafeUnaryOpL :: ByteString -> x :--> y -unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x +unsafeLeftOp :: ByteString -> x --> y +unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x --- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE" +-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE" -- (TRUE IS NOT TRUE) -unsafeUnaryOpR :: ByteString -> x :--> y -unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op +unsafeRightOp :: ByteString -> x --> y +unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op -- | >>> printSQL $ unsafeFunction "f" true -- f(TRUE) -unsafeFunction :: ByteString -> x :--> y +unsafeFunction :: ByteString -> x --> y unsafeFunction fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x) --- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a') --- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a') -unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y +{- | Call a user defined function of a single variable + +>>> type Fn = '[ 'Null 'PGint4] :=> 'Returns ('NotNull 'PGnumeric) +>>> type Schema = '["fn" ::: 'Function Fn] +>>> :{ +let + fn :: Fun (Public Schema) ('Null 'PGint4) ('NotNull 'PGnumeric) + fn = function #fn +in + printSQL (fn 1) +:} +"fn"((1 :: int4)) +-} +function + :: (Has sch db schema, Has fun schema ('Function ('[x] :=> 'Returns y))) + => QualifiedAlias sch fun -- ^ function name + -> Fun db x y +function f = unsafeFunction $ renderSQL f + +-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: inline 'a') +-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, (E'a' :: char(1))) +unsafeFunctionN :: SListI xs => ByteString -> xs ---> y unsafeFunctionN fun xs = UnsafeExpression $ fun <> parenthesized (renderCommaSeparated renderSQL xs) -instance ty `In` PGNum - => Num (Expression outer commons grp schemas params from (null ty)) where +{- | Call a user defined multivariable function + +>>> type Fn = '[ 'Null 'PGint4, 'Null 'PGbool] :=> 'Returns ('NotNull 'PGnumeric) +>>> type Schema = '["fn" ::: 'Function Fn] +>>> :{ +let + fn :: FunN (Public Schema) '[ 'Null 'PGint4, 'Null 'PGbool] ('NotNull 'PGnumeric) + fn = functionN #fn +in + printSQL (fn (1 *: true)) +:} +"fn"((1 :: int4), TRUE) +-} +functionN + :: ( Has sch db schema + , Has fun schema ('Function (xs :=> 'Returns y)) + , SListI xs ) + => QualifiedAlias sch fun -- ^ function alias + -> FunN db xs y +functionN f = unsafeFunctionN $ renderSQL f + +instance + Num (Expression grp lat with db params from (null 'PGint2)) where (+) = unsafeBinaryOp "+" (-) = unsafeBinaryOp "-" (*) = unsafeBinaryOp "*" @@ -317,21 +381,143 @@ signum = unsafeFunction "sign" fromInteger = UnsafeExpression - . fromString - . show + . parenthesized + . (<> " :: int2") + . toStrict + . toLazyByteString + . int16Dec + . fromInteger +instance + Num (Expression grp lat with db params from (null 'PGint4)) where + (+) = unsafeBinaryOp "+" + (-) = unsafeBinaryOp "-" + (*) = unsafeBinaryOp "*" + abs = unsafeFunction "abs" + signum = unsafeFunction "sign" + fromInteger + = UnsafeExpression + . parenthesized + . (<> " :: int4") + . toStrict + . toLazyByteString + . int32Dec + . fromInteger +instance + Num (Expression grp lat with db params from (null 'PGint8)) where + (+) = unsafeBinaryOp "+" + (-) = unsafeBinaryOp "-" + (*) = unsafeBinaryOp "*" + abs = unsafeFunction "abs" + signum = unsafeFunction "sign" + fromInteger x = + let + y = fromInteger x + in + if y == minBound + -- For some reason Postgres throws an error with + -- (-9223372036854775808 :: int8) + -- even though it's a valid lowest value for int8 + then fromInteger (x+1) - 1 + else UnsafeExpression + . parenthesized + . (<> " :: int8") + . toStrict + . toLazyByteString + $ int64Dec y +instance + Num (Expression grp lat with db params from (null 'PGfloat4)) where + (+) = unsafeBinaryOp "+" + (-) = unsafeBinaryOp "-" + (*) = unsafeBinaryOp "*" + abs = unsafeFunction "abs" + signum = unsafeFunction "sign" + fromInteger x + = UnsafeExpression + . parenthesized + . (<> " :: float4") $ + let + y = fromInteger x + decimal = toStrict . toLazyByteString . floatDec + in + if isNaN y || isInfinite y + then singleQuotedUtf8 (decimal y) + else decimal y +instance + Num (Expression grp lat with db params from (null 'PGfloat8)) where + (+) = unsafeBinaryOp "+" + (-) = unsafeBinaryOp "-" + (*) = unsafeBinaryOp "*" + abs = unsafeFunction "abs" + signum = unsafeFunction "sign" + fromInteger x + = UnsafeExpression + . parenthesized + . (<> " :: float8") $ + let + y = fromInteger x + decimal = toStrict . toLazyByteString . doubleDec + in + if isNaN y || isInfinite y + then singleQuotedUtf8 (decimal y) + else decimal y +instance + Num (Expression grp lat with db params from (null 'PGnumeric)) where + (+) = unsafeBinaryOp "+" + (-) = unsafeBinaryOp "-" + (*) = unsafeBinaryOp "*" + abs = unsafeFunction "abs" + signum = unsafeFunction "sign" + fromInteger + = UnsafeExpression + . parenthesized + . (<> " :: numeric") + . toStrict + . toLazyByteString + . scientificBuilder + . fromInteger -instance (ty `In` PGNum, ty `In` PGFloating) => Fractional - (Expression outer commons grp schemas params from (null ty)) where +instance Fractional + (Expression grp lat with db params from (null 'PGfloat4)) where (/) = unsafeBinaryOp "/" + fromRational x + = UnsafeExpression + . parenthesized + . (<> " :: float4") $ + let + y = fromRational x + decimal = toStrict . toLazyByteString . floatDec + in + if isNaN y || isInfinite y + then singleQuotedUtf8 (decimal y) + else decimal y +instance Fractional + (Expression grp lat with db params from (null 'PGfloat8)) where + (/) = unsafeBinaryOp "/" + fromRational x + = UnsafeExpression + . parenthesized + . (<> " :: float8") $ + let + y = fromRational x + decimal = toStrict . toLazyByteString . doubleDec + in + if isNaN y || isInfinite y + then singleQuotedUtf8 (decimal y) + else decimal y +instance Fractional + (Expression grp lat with db params from (null 'PGnumeric)) where + (/) = unsafeBinaryOp "/" fromRational = UnsafeExpression - . fromString - . ($ "") - . showFFloat Nothing - . fromRat @Double + . parenthesized + . (<> " :: numeric") + . toStrict + . toLazyByteString + . scientificBuilder + . fromRational -instance (ty `In` PGNum, ty `In` PGFloating) => Floating - (Expression outer commons grp schemas params from (null ty)) where +instance Floating + (Expression grp lat with db params from (null 'PGfloat4)) where pi = UnsafeExpression "pi()" exp = unsafeFunction "exp" log = unsafeFunction "ln" @@ -351,48 +537,109 @@ asinh x = log (x + sqrt (x*x + 1)) acosh x = log (x + sqrt (x*x - 1)) atanh x = log ((1 + x) / (1 - x)) / 2 +instance Floating + (Expression grp lat with db params from (null 'PGfloat8)) where + pi = UnsafeExpression "pi()" + exp = unsafeFunction "exp" + log = unsafeFunction "ln" + sqrt = unsafeFunction "sqrt" + b ** x = UnsafeExpression $ + "power(" <> renderSQL b <> ", " <> renderSQL x <> ")" + logBase b y = log y / log b + sin = unsafeFunction "sin" + cos = unsafeFunction "cos" + tan = unsafeFunction "tan" + asin = unsafeFunction "asin" + acos = unsafeFunction "acos" + atan = unsafeFunction "atan" + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + tanh x = sinh x / cosh x + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = log ((1 + x) / (1 - x)) / 2 +instance Floating + (Expression grp lat with db params from (null 'PGnumeric)) where + pi = UnsafeExpression "pi()" + exp = unsafeFunction "exp" + log = unsafeFunction "ln" + sqrt = unsafeFunction "sqrt" + b ** x = UnsafeExpression $ + "power(" <> renderSQL b <> ", " <> renderSQL x <> ")" + logBase b y = log y / log b + sin = unsafeFunction "sin" + cos = unsafeFunction "cos" + tan = unsafeFunction "tan" + asin = unsafeFunction "asin" + acos = unsafeFunction "acos" + atan = unsafeFunction "atan" + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + tanh x = sinh x / cosh x + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = log ((1 + x) / (1 - x)) / 2 -- | Contained by operators -class PGSubset container where - (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool) +class PGSubset ty where + (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) (@>) = unsafeBinaryOp "@>" - (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool) + (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) (<@) = unsafeBinaryOp "<@" +infix 4 @> +infix 4 <@ instance PGSubset 'PGjsonb instance PGSubset 'PGtsquery instance PGSubset ('PGvararray ty) +instance PGSubset ('PGrange ty) +-- | Intersection operator +class PGIntersect ty where + (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) + (@&&) = unsafeBinaryOp "&&" +instance PGIntersect ('PGvararray ty) +instance PGIntersect ('PGrange ty) + instance IsString - (Expression outer commons grp schemas params from (null 'PGtext)) where - fromString str = UnsafeExpression $ - "E\'" <> fromString (escape =<< str) <> "\'" + (Expression grp lat with db params from (null 'PGtext)) where + fromString + = UnsafeExpression + . parenthesized + . (<> " :: text") + . escapeQuotedString instance IsString - (Expression outer commons grp schemas params from (null 'PGtsvector)) where - fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $ - "E\'" <> fromString (escape =<< str) <> "\'" + (Expression grp lat with db params from (null 'PGtsvector)) where + fromString + = UnsafeExpression + . parenthesized + . (<> " :: tsvector") + . escapeQuotedString instance IsString - (Expression outer commons grp schemas params from (null 'PGtsquery)) where - fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $ - "E\'" <> fromString (escape =<< str) <> "\'" + (Expression grp lat with db params from (null 'PGtsquery)) where + fromString + = UnsafeExpression + . parenthesized + . (<> " :: tsquery") + . escapeQuotedString instance Semigroup - (Expression outer commons grp schemas params from (null ('PGvararray ty))) where + (Expression grp lat with db params from (null ('PGvararray ty))) where (<>) = unsafeBinaryOp "||" instance Semigroup - (Expression outer commons grp schemas params from (null 'PGjsonb)) where + (Expression grp lat with db params from (null 'PGjsonb)) where (<>) = unsafeBinaryOp "||" instance Semigroup - (Expression outer commons grp schemas params from (null 'PGtext)) where + (Expression grp lat with db params from (null 'PGtext)) where (<>) = unsafeBinaryOp "||" instance Semigroup - (Expression outer commons grp schemas params from (null 'PGtsvector)) where + (Expression grp lat with db params from (null 'PGtsvector)) where (<>) = unsafeBinaryOp "||" instance Monoid - (Expression outer commons grp schemas params from (null 'PGtext)) where + (Expression grp lat with db params from (null 'PGtext)) where mempty = fromString "" mappend = (<>) instance Monoid - (Expression outer commons grp schemas params from (null 'PGtsvector)) where + (Expression grp lat with db params from (null 'PGtsvector)) where mempty = fromString "" mappend = (<>) 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 @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Aggregate -Description: Aggregate functions +Description: aggregate functions and arguments Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Aggregate functions +aggregate functions and arguments -} {-# LANGUAGE @@ -17,99 +17,124 @@ , LambdaCase , MultiParamTypeClasses , OverloadedStrings + , PatternSynonyms , PolyKinds + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications , TypeFamilies , TypeOperators , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Aggregate - ( Aggregate (..) - , Distinction (..) + ( -- * Aggregate + Aggregate (..) + -- * Aggregate Arguments + , AggregateArg (..) + , pattern All + , pattern Alls + , allNotNull + , pattern Distinct + , pattern Distincts + , distinctNotNull + , FilterWhere (..) + -- * Aggregate Types , PGSum , PGAvg ) where -import Control.DeepSeq import Data.ByteString (ByteString) -import Data.Kind import GHC.TypeLits -import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP -import Squeal.PostgreSQL.Alias +import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.List +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Expression.Null +import Squeal.PostgreSQL.Expression.Sort +import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL {- | `Aggregate` functions compute a single result from a set of input values. -`Aggregate` functions can be used as `GroupedBy` `Expression`s as well +`Aggregate` functions can be used as `Grouped` `Expression`s as well as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s. -} -class Aggregate expr1 exprN aggr - | aggr -> expr1, aggr -> exprN where +class Aggregate arg expr | expr -> arg where -- | A special aggregation that does not require an input -- -- >>> :{ -- let - -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8) + -- expression :: Expression ('Grouped bys) '[] with db params from ('NotNull 'PGint8) -- expression = countStar -- in printSQL expression -- :} -- count(*) - countStar :: aggr ('NotNull 'PGint8) + countStar :: expr lat with db params from ('NotNull 'PGint8) -- | >>> :{ -- let - -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8) + -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8) -- expression = count (All #col) -- in printSQL expression -- :} -- count(ALL "col") count - :: expr1 ty - -- ^ what to count - -> aggr ('NotNull 'PGint8) + :: arg '[ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('NotNull 'PGint8) -- | >>> :{ -- let - -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric) - -- expression = sum_ (Distinct #col) + -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric) + -- expression = sum_ (Distinct #col & filterWhere (#col .< 100)) -- in printSQL expression -- :} - -- sum(DISTINCT "col") + -- sum(DISTINCT "col") FILTER (WHERE ("col" < (100.0 :: numeric))) sum_ - :: expr1 (null ty) - -> aggr ('Null (PGSum ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGSum ty)) -- | input values, including nulls, concatenated into an array + -- + -- >>> :{ + -- let + -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null ('PGvararray ('Null 'PGnumeric))) + -- expression = arrayAgg (All #col & orderBy [AscNullsFirst #col] & filterWhere (#col .< 100)) + -- in printSQL expression + -- :} + -- array_agg(ALL "col" ORDER BY "col" ASC NULLS FIRST) FILTER (WHERE ("col" < (100.0 :: numeric))) arrayAgg - :: expr1 ty - -> aggr ('Null ('PGvararray ty)) + :: arg '[ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null ('PGvararray ty)) -- | aggregates values as a JSON array jsonAgg - :: expr1 ty - -> aggr ('Null 'PGjson) + :: arg '[ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null 'PGjson) -- | aggregates values as a JSON array jsonbAgg - :: expr1 ty - -> aggr ('Null 'PGjsonb) + :: arg '[ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null 'PGjsonb) {- | the bitwise AND of all non-null input values, or null if none >>> :{ let - expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) + expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) expression = bitAnd (Distinct #col) in printSQL expression :} @@ -117,16 +142,16 @@ -} bitAnd :: int `In` PGIntegral - => expr1 (null int) - -- ^ what to aggregate - -> aggr ('Null int) + => arg '[null int] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null int) {- | the bitwise OR of all non-null input values, or null if none >>> :{ let - expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) + expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) expression = bitOr (All #col) in printSQL expression :} @@ -134,307 +159,464 @@ -} bitOr :: int `In` PGIntegral - => expr1 (null int) - -- ^ what to aggregate - -> aggr ('Null int) + => arg '[null int] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null int) {- | true if all input values are true, otherwise false >>> :{ let - winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) - winFun = boolAnd #col + winFun :: WindowFunction 'Ungrouped '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) + winFun = boolAnd (Window #col) in printSQL winFun :} bool_and("col") -} boolAnd - :: expr1 (null 'PGbool) - -- ^ what to aggregate - -> aggr ('Null 'PGbool) + :: arg '[null 'PGbool] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null 'PGbool) {- | true if at least one input value is true, otherwise false >>> :{ let - expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) + expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) expression = boolOr (All #col) in printSQL expression :} bool_or(ALL "col") -} boolOr - :: expr1 (null 'PGbool) - -- ^ what to aggregate - -> aggr ('Null 'PGbool) + :: arg '[null 'PGbool] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null 'PGbool) {- | equivalent to `boolAnd` >>> :{ let - expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) + expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) expression = every (Distinct #col) in printSQL expression :} every(DISTINCT "col") -} every - :: expr1 (null 'PGbool) - -- ^ what to aggregate - -> aggr ('Null 'PGbool) + :: arg '[null 'PGbool] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null 'PGbool) {- |maximum value of expression across all input values-} max_ - :: expr1 (null ty) - -- ^ what to maximize - -> aggr ('Null ty) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null ty) -- | minimum value of expression across all input values min_ - :: expr1 (null ty) - -- ^ what to minimize - -> aggr ('Null ty) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null ty) -- | the average (arithmetic mean) of all input values avg - :: expr1 (null ty) - -- ^ what to average - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) {- | correlation coefficient >>> :{ let - expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = corr (All (#y *: #x)) + expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) + expression = corr (Alls (#y *: #x)) in printSQL expression :} corr(ALL "y", "x") -} corr - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) {- | population covariance >>> :{ let - expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = covarPop (All (#y *: #x)) + expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) + expression = covarPop (Alls (#y *: #x)) in printSQL expression :} covar_pop(ALL "y", "x") -} covarPop - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) {- | sample covariance >>> :{ let - winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - winFun = covarSamp (#y *: #x) + winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) + winFun = covarSamp (Windows (#y *: #x)) in printSQL winFun :} covar_samp("y", "x") -} covarSamp - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) {- | average of the independent variable (sum(X)/N) >>> :{ let - expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = regrAvgX (All (#y *: #x)) + expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) + expression = regrAvgX (Alls (#y *: #x)) in printSQL expression :} regr_avgx(ALL "y", "x") -} regrAvgX - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) {- | average of the dependent variable (sum(Y)/N) >>> :{ let - winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - winFun = regrAvgY (#y *: #x) + winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) + winFun = regrAvgY (Windows (#y *: #x)) in printSQL winFun :} regr_avgy("y", "x") -} regrAvgY - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) {- | number of input rows in which both expressions are nonnull >>> :{ let - winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8) - winFun = regrCount (#y *: #x) + winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8) + winFun = regrCount (Windows (#y *: #x)) in printSQL winFun :} regr_count("y", "x") -} regrCount - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGint8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGint8) {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs + >>> :{ let - expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = regrIntercept (All (#y *: #x)) + expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) + expression = regrIntercept (Alls (#y *: #x)) in printSQL expression :} regr_intercept(ALL "y", "x") -} regrIntercept - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_r2(Y, X)@, square of the correlation coefficient regrR2 - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation -- determined by the (X, Y) pairs regrSlope - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N -- (“sum of squares” of the independent variable) regrSxx - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N -- (“sum of products” of independent times dependent variable) regrSxy - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N -- (“sum of squares” of the dependent variable) regrSyy - :: exprN '[null 'PGfloat8, null 'PGfloat8] - -> aggr ('Null 'PGfloat8) + :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from + -- ^ arguments + -> expr lat with db params from ('Null 'PGfloat8) -- | historical alias for `stddevSamp` stddev - :: expr1 (null ty) - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) -- | population standard deviation of the input values stddevPop - :: expr1 (null ty) - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) -- | sample standard deviation of the input values stddevSamp - :: expr1 (null ty) - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) -- | historical alias for `varSamp` variance - :: expr1 (null ty) - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) -- | population variance of the input values -- (square of the population standard deviation) varPop - :: expr1 (null ty) - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) -- | sample variance of the input values -- (square of the sample standard deviation) varSamp - :: expr1 (null ty) - -> aggr ('Null (PGAvg ty)) + :: arg '[null ty] lat with db params from + -- ^ argument + -> expr lat with db params from ('Null (PGAvg ty)) {- | -`Distinction`s are used for the input of `Aggregate` `Expression`s. -`All` invokes the aggregate once for each input row. -`Distinct` invokes the aggregate once for each distinct value of the expression -(or distinct set of values, for multiple expressions) found in the input +`AggregateArg`s are used for the input of `Aggregate` `Expression`s. -} -data Distinction (expr :: kind -> Type) (ty :: kind) - = All (expr ty) - | Distinct (expr ty) - deriving (GHC.Generic,Show,Eq,Ord) -instance NFData (Distinction (Expression outer commons grp schemas params from) ty) -instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where +data AggregateArg + (xs :: [NullType]) + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (from :: FromType) + = AggregateAll + { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs + , aggregateOrder :: [SortExpression '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] + -- ^ `orderBy` + , aggregateFilter :: [Condition 'Ungrouped lat with db params from] + -- ^ `filterWhere` + } + +instance (HasUnique tab (Join from lat) row, Has col row ty) + => IsLabel col (AggregateArg '[ty] lat with db params from) where + fromLabel = All (fromLabel @col) +instance (Has tab (Join from lat) row, Has col row ty) + => IsQualified tab col (AggregateArg '[ty] lat with db params from) where + tab ! col = All (tab ! col) + +instance SOP.SListI xs => RenderSQL (AggregateArg xs lat with db params from) where renderSQL = \case - All x -> "ALL" <+> renderSQL x - Distinct x -> "DISTINCT" <+> renderSQL x -instance SOP.SListI tys => RenderSQL - (Distinction (NP (Expression outer commons grp schemas params from)) tys) where - renderSQL = \case - All xs -> "ALL" <+> renderCommaSeparated renderSQL xs - Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs + AggregateAll args sorts filters -> + parenthesized + ("ALL" <+> renderCommaSeparated renderSQL args<> renderSQL sorts) + <> renderFilters filters + AggregateDistinct args sorts filters -> + parenthesized + ("DISTINCT" <+> renderCommaSeparated renderSQL args <> renderSQL sorts) + <> renderFilters filters + where + renderFilter wh = "FILTER" <+> parenthesized ("WHERE" <+> wh) + renderFilters = \case + [] -> "" + wh:whs -> " " <> renderFilter (renderSQL (foldr (.&&) wh whs)) -instance Aggregate - (Distinction (Expression outer commons 'Ungrouped schemas params from)) - (Distinction (NP (Expression outer commons 'Ungrouped schemas params from))) - (Expression outer commons ('Grouped bys) schemas params from) where - countStar = UnsafeExpression "count(*)" - count = unsafeAggregate1 "count" - sum_ = unsafeAggregate1 "sum" - arrayAgg = unsafeAggregate1 "array_agg" - jsonAgg = unsafeAggregate1 "json_agg" - jsonbAgg = unsafeAggregate1 "jsonb_agg" - bitAnd = unsafeAggregate1 "bit_and" - bitOr = unsafeAggregate1 "bit_or" - boolAnd = unsafeAggregate1 "bool_and" - boolOr = unsafeAggregate1 "bool_or" - every = unsafeAggregate1 "every" - max_ = unsafeAggregate1 "max" - min_ = unsafeAggregate1 "min" - avg = unsafeAggregate1 "avg" - corr = unsafeAggregateN "corr" - covarPop = unsafeAggregateN "covar_pop" - covarSamp = unsafeAggregateN "covar_samp" - regrAvgX = unsafeAggregateN "regr_avgx" - regrAvgY = unsafeAggregateN "regr_avgy" - regrCount = unsafeAggregateN "regr_count" - regrIntercept = unsafeAggregateN "regr_intercept" - regrR2 = unsafeAggregateN "regr_r2" - regrSlope = unsafeAggregateN "regr_slope" - regrSxx = unsafeAggregateN "regr_sxx" - regrSxy = unsafeAggregateN "regr_sxy" - regrSyy = unsafeAggregateN "regr_syy" - stddev = unsafeAggregate1 "stddev" - stddevPop = unsafeAggregate1 "stddev_pop" - stddevSamp = unsafeAggregate1 "stddev_samp" - variance = unsafeAggregate1 "variance" - varPop = unsafeAggregate1 "var_pop" - varSamp = unsafeAggregate1 "var_samp" +instance OrderBy (AggregateArg xs) 'Ungrouped where + orderBy sorts1 = \case + AggregateAll xs sorts0 whs -> AggregateAll xs (sorts0 ++ sorts1) whs + AggregateDistinct xs sorts0 whs -> AggregateDistinct xs (sorts0 ++ sorts1) whs --- | escape hatch to define aggregate functions -unsafeAggregate1 - :: ByteString -- ^ aggregate function - -> Distinction (Expression outer commons 'Ungrouped schemas params from) x - -> Expression outer commons ('Grouped bys) schemas params from y -unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x) +-- | `All` invokes the aggregate on a single +-- 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) -unsafeAggregateN +-- | `All` invokes the aggregate on multiple +-- 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 [] [] + +-- | `allNotNull` invokes the aggregate on a single +-- argument once for each input row where the argument +-- 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)) + +{- | +`Distinct` invokes the aggregate once for each +distinct value of the expression found in the input. +-} +pattern Distinct + :: Expression 'Ungrouped lat with db params from x + -- ^ argument + -> AggregateArg '[x] lat with db params from +pattern Distinct x = Distincts (x :* Nil) + +{- | +`Distincts` invokes the aggregate once for each +distinct set of values, for multiple expressions, found in the input. +-} +pattern Distincts + :: NP (Expression 'Ungrouped lat with db params from) xs + -- ^ arguments + -> AggregateArg xs lat with db params from +pattern Distincts xs = AggregateDistinct xs [] [] + +{- | +`distinctNotNull` invokes the aggregate once for each +distinct, not null value of the expression found in the input. +-} +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)) + +-- | Permits filtering +-- `Squeal.PostgreSQL.Expression.Window.WindowArg`s and `AggregateArg`s +class FilterWhere arg grp | arg -> grp where + {- | + If `filterWhere` is specified, then only the input rows for which + the `Condition` evaluates to true are fed to the aggregate function; + other rows are discarded. + -} + 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 + filterWhere wh = \case + AggregateAll xs sorts whs -> AggregateAll xs sorts (wh : whs) + AggregateDistinct xs sorts whs -> AggregateDistinct xs sorts (wh : whs) + +instance Aggregate AggregateArg (Expression ('Grouped bys)) where + countStar = UnsafeExpression "count(*)" + count = unsafeAggregate "count" + sum_ = unsafeAggregate "sum" + arrayAgg = unsafeAggregate "array_agg" + jsonAgg = unsafeAggregate "json_agg" + jsonbAgg = unsafeAggregate "jsonb_agg" + bitAnd = unsafeAggregate "bit_and" + bitOr = unsafeAggregate "bit_or" + boolAnd = unsafeAggregate "bool_and" + boolOr = unsafeAggregate "bool_or" + every = unsafeAggregate "every" + max_ = unsafeAggregate "max" + min_ = unsafeAggregate "min" + avg = unsafeAggregate "avg" + corr = unsafeAggregate "corr" + covarPop = unsafeAggregate "covar_pop" + covarSamp = unsafeAggregate "covar_samp" + regrAvgX = unsafeAggregate "regr_avgx" + regrAvgY = unsafeAggregate "regr_avgy" + regrCount = unsafeAggregate "regr_count" + regrIntercept = unsafeAggregate "regr_intercept" + regrR2 = unsafeAggregate "regr_r2" + regrSlope = unsafeAggregate "regr_slope" + regrSxx = unsafeAggregate "regr_sxx" + regrSxy = unsafeAggregate "regr_sxy" + regrSyy = unsafeAggregate "regr_syy" + stddev = unsafeAggregate "stddev" + stddevPop = unsafeAggregate "stddev_pop" + stddevSamp = unsafeAggregate "stddev_samp" + variance = unsafeAggregate "variance" + varPop = unsafeAggregate "var_pop" + varSamp = unsafeAggregate "var_samp" + +-- provides a nicer type error when we forget to group by +-- note that we need to make our 'a' polymorphic so that we can still match when it's ambiguous +instance ( TypeError ('Text "Cannot use aggregate functions to construct an Ungrouped Expression. Add a 'groupBy' to your TableExpression. If you want to aggregate across the entire result set, use 'groupBy Nil'.") + , a ~ AggregateArg + ) => Aggregate a (Expression 'Ungrouped) where + countStar = impossibleAggregateError + count = impossibleAggregateError + sum_ = impossibleAggregateError + arrayAgg = impossibleAggregateError + jsonAgg = impossibleAggregateError + jsonbAgg = impossibleAggregateError + bitAnd = impossibleAggregateError + bitOr = impossibleAggregateError + boolAnd = impossibleAggregateError + boolOr = impossibleAggregateError + every = impossibleAggregateError + max_ = impossibleAggregateError + min_ = impossibleAggregateError + avg = impossibleAggregateError + corr = impossibleAggregateError + covarPop = impossibleAggregateError + covarSamp = impossibleAggregateError + regrAvgX = impossibleAggregateError + regrAvgY = impossibleAggregateError + regrCount = impossibleAggregateError + regrIntercept = impossibleAggregateError + regrR2 = impossibleAggregateError + regrSlope = impossibleAggregateError + regrSxx = impossibleAggregateError + regrSxy = impossibleAggregateError + regrSyy = impossibleAggregateError + stddev = impossibleAggregateError + stddevPop = impossibleAggregateError + stddevSamp = impossibleAggregateError + variance = impossibleAggregateError + varPop = impossibleAggregateError + varSamp = impossibleAggregateError + +-- | helper function for our errors above +impossibleAggregateError :: a +impossibleAggregateError = error "impossible; called aggregate function for Ungrouped even though the Aggregate instance has a type error constraint." + +-- | escape hatch to define aggregate functions +unsafeAggregate :: SOP.SListI xs => ByteString -- ^ function - -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs - -> Expression outer commons ('Grouped bys) schemas params from y -unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs) + -> AggregateArg xs lat with db params from + -> Expression ('Grouped bys) lat with db params from y +unsafeAggregate fun xs = UnsafeExpression $ fun <> renderSQL xs --- | A type family that calculates `PGSum``PGType` of +-- | A type family that calculates `PGSum` `PGType` of -- a given argument `PGType`. type family PGSum ty where PGSum 'PGint2 = 'PGint8 diff --git a/src/Squeal/PostgreSQL/Expression/Array.hs b/src/Squeal/PostgreSQL/Expression/Array.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Expression/Array.hs @@ -0,0 +1,291 @@ +{-| +Module: Squeal.PostgreSQL.Expression.Array +Description: array functions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +array functions +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Expression.Array + ( -- * Array Functions + array + , array0 + , array1 + , array2 + , cardinality + , index + , index1 + , index2 + , unnest + , arrAny + , arrAll + , arrayAppend + , arrayPrepend + , arrayCat + , arrayPosition + , arrayPositionBegins + , arrayPositions + , arrayRemoveNull + , arrayReplace + , trimArray + ) 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.Null +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Query.From.Set +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | Construct an array. +-- +-- >>> printSQL $ array [null_, false, true] +-- ARRAY[NULL, FALSE, TRUE] +array + :: [Expression grp lat with db params from ty] + -- ^ array elements + -> Expression grp lat with db params from (null ('PGvararray ty)) +array xs = UnsafeExpression $ "ARRAY" <> + bracketed (commaSeparated (renderSQL <$> xs)) + +-- | Safely construct an empty array. +-- +-- >>> printSQL $ array0 text +-- (ARRAY[] :: text[]) +array0 + :: TypeExpression db ty + -> Expression grp lat with db params from (null ('PGvararray ty)) +array0 ty = array [] & astype (vararray ty) + +{- | Construct a fixed length array. + +>>> printSQL $ array1 (null_ :* false *: true) +ARRAY[NULL, FALSE, TRUE] + +>>> :type array1 (null_ :* false *: true) +array1 (null_ :* false *: true) + :: Expression + grp + lat + with + db + params + from + (null ('PGfixarray '[3] ('Null 'PGbool))) +-} +array1 + :: (n ~ Length tys, SOP.All ((~) ty) tys) + => NP (Expression grp lat with db params from) tys + -- ^ array elements + -> Expression grp lat with db params from (null ('PGfixarray '[n] ty)) +array1 xs = UnsafeExpression $ "ARRAY" <> + bracketed (renderCommaSeparated renderSQL xs) + +{- | Construct a fixed size matrix. + +>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true)) +ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]] + +>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true)) +array2 ((null_ :* false *: true) *: (false :* null_ *: true)) + :: Expression + grp + lat + with + db + params + from + (null ('PGfixarray '[2, 3] ('Null 'PGbool))) +-} +array2 + :: ( SOP.All ((~) tys) tyss + , SOP.All SOP.SListI tyss + , Length tyss ~ n1 + , SOP.All ((~) ty) tys + , Length tys ~ n2 ) + => NP (NP (Expression grp lat with db params from)) tyss + -- ^ matrix elements + -> Expression grp lat with db params from (null ('PGfixarray '[n1,n2] ty)) +array2 xss = UnsafeExpression $ "ARRAY" <> + bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss) + +-- | >>> printSQL $ cardinality (array [null_, false, true]) +-- cardinality(ARRAY[NULL, FALSE, TRUE]) +cardinality :: null ('PGvararray ty) --> null 'PGint8 +cardinality = unsafeFunction "cardinality" + +-- | >>> printSQL $ array [null_, false, true] & index 2 +-- (ARRAY[NULL, FALSE, TRUE])[2] +index + :: Word64 -- ^ index + -> null ('PGvararray ty) --> NullifyType ty +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)) + +arrayAppend :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty) +arrayAppend = unsafeFunctionN "array_append" + +arrayPrepend :: '[ty, null ('PGvararray ty)] ---> null ('PGvararray ty) +arrayPrepend = unsafeFunctionN "array_prepend" + +arrayCat + :: '[null ('PGvararray ty), null ('PGvararray ty)] + ---> null ('PGvararray ty) +arrayCat = unsafeFunctionN "array_cat" + +arrayPosition :: '[null ('PGvararray ty), ty] ---> 'Null 'PGint8 +arrayPosition = unsafeFunctionN "array_position" + +arrayPositionBegins + :: '[null ('PGvararray ty), ty, null 'PGint8] ---> 'Null 'PGint8 +arrayPositionBegins = unsafeFunctionN "array_position" + +arrayPositions + :: '[null ('PGvararray ty), ty] + ---> null ('PGvararray ('NotNull 'PGint8)) +arrayPositions = unsafeFunctionN "array_positions" + +arrayRemove :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty) +arrayRemove = unsafeFunctionN "array_remove" + +arrayRemoveNull :: null ('PGvararray ('Null ty)) --> null ('PGvararray ('NotNull ty)) +arrayRemoveNull arr = UnsafeExpression (renderSQL (arrayRemove (arr *: null_))) + +arrayReplace + :: '[null ('PGvararray ty), ty, ty] + ---> null ('PGvararray ty) +arrayReplace = unsafeFunctionN "array_replace" + +trimArray + :: '[null ('PGvararray ty), 'NotNull 'PGint8] + ---> null ('PGvararray ty) +trimArray = unsafeFunctionN "trim_array" diff --git a/src/Squeal/PostgreSQL/Expression/Collection.hs b/src/Squeal/PostgreSQL/Expression/Collection.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Expression/Collection.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Collection -Description: Array and composite functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Array and composite functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Collection - ( array - , array1 - , array2 - , cardinality - , index - , unnest - , row - , field - ) where - -import Data.String -import Data.Word (Word64) - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.SetOf -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | >>> printSQL $ array [null_, false, true] --- ARRAY[NULL, FALSE, TRUE] -array - :: [Expression outer commons grp schemas params from ty] - -- ^ array elements - -> Expression outer commons grp schemas params from (null ('PGvararray ty)) -array xs = UnsafeExpression $ "ARRAY" <> - bracketed (commaSeparated (renderSQL <$> xs)) - -{- | construct a 1-dimensional fixed length array - ->>> printSQL $ array1 (null_ :* false *: true) -ARRAY[NULL, FALSE, TRUE] - ->>> :type array1 (null_ :* false *: true) -array1 (null_ :* false *: true) - :: Expression - outer - commons - grp - schemas - params - from - (null ('PGfixarray '[3] ('Null 'PGbool))) --} -array1 - :: (n ~ Length tys, SOP.All ((~) ty) tys) - => NP (Expression outer commons grp schemas params from) tys - -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty)) -array1 xs = UnsafeExpression $ "ARRAY" <> - bracketed (renderCommaSeparated renderSQL xs) - -{- | construct a 2-dimensional fixed length array - ->>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true)) -ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]] - ->>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true)) -array2 ((null_ :* false *: true) *: (false :* null_ *: true)) - :: Expression - outer - commons - grp - schemas - params - from - (null ('PGfixarray '[2, 3] ('Null 'PGbool))) --} -array2 - :: ( SOP.All ((~) tys) tyss - , SOP.All SOP.SListI tyss - , Length tyss ~ n1 - , SOP.All ((~) ty) tys - , Length tys ~ n2 ) - => NP (NP (Expression outer commons grp schemas params from)) tyss - -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty)) -array2 xss = UnsafeExpression $ "ARRAY" <> - bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss) - --- | >>> printSQL $ cardinality (array [null_, false, true]) --- cardinality(ARRAY[NULL, FALSE, TRUE]) -cardinality :: null ('PGvararray ty) :--> null 'PGint8 -cardinality = unsafeFunction "cardinality" - --- | >>> printSQL $ array [null_, false, true] & index 2 --- (ARRAY[NULL, FALSE, TRUE])[2] -index - :: Word64 -- ^ index - -> null ('PGvararray ty) :--> NullifyType ty -index n expr = UnsafeExpression $ - parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]" - --- | Expand an array to a set of rows -unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty] -unnest = unsafeSetOfFunction - --- | A row constructor is an expression that builds a row value --- (also called a composite value) using values for its member fields. --- --- >>> :{ --- type Complex = 'PGcomposite --- '[ "real" ::: 'NotNull 'PGfloat8 --- , "imaginary" ::: 'NotNull 'PGfloat8 ] --- :} --- --- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex) --- >>> printSQL i --- ROW(0, 1) -row - :: SOP.SListI row - => NP (Aliased (Expression outer commons grp schemas params from)) row - -- ^ zero or more expressions for the row field values - -> Expression outer commons grp schemas params from (null ('PGcomposite row)) -row exprs = UnsafeExpression $ "ROW" <> parenthesized - (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs) - --- | >>> :{ --- type Complex = 'PGcomposite --- '[ "real" ::: 'NotNull 'PGfloat8 --- , "imaginary" ::: 'NotNull 'PGfloat8 ] --- type Schema = '["complex" ::: 'Typedef Complex] --- :} --- --- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex) --- >>> printSQL $ i & field #complex #imaginary --- (ROW(0, 1)::"complex")."imaginary" -field - :: ( Has sch schemas schema - , Has tydef schema ('Typedef ('PGcomposite row)) - , Has field row ty) - => QualifiedAlias sch tydef -- ^ row type - -> Alias field -- ^ field name - -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row)) - -> Expression outer commons grp schemas params from ty -field td fld expr = UnsafeExpression $ - parenthesized (renderSQL expr <> "::" <> renderSQL td) - <> "." <> renderSQL fld 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 @@ -1,34 +1,39 @@ {-| Module: Squeal.PostgreSQL.Expression.Comparison -Description: Comparison expressions +Description: comparison functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Comparison functions and operators +comparison functions and operators -} {-# LANGUAGE OverloadedStrings , RankNTypes - , TypeInType + , DataKinds + , PolyKinds , TypeOperators #-} module Squeal.PostgreSQL.Expression.Comparison - ( (.==) + ( -- * Comparison Operators + (.==) , (./=) , (.>=) , (.<) , (.<=) , (.>) + -- * Comparison Functions , greatest , least + -- * Between , BetweenExpr , between , notBetween , betweenSymmetric , notBetweenSymmetric + -- * Null Comparison , isDistinctFrom , isNotDistinctFrom , isTrue @@ -44,7 +49,7 @@ import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -88,7 +93,7 @@ (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ '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 @@ -103,11 +108,11 @@ A @RankNType@ for comparison expressions like `between`. -} type BetweenExpr - = forall outer commons grp schemas params from ty - . Expression outer commons grp schemas params from ty - -> ( Expression outer commons grp schemas params from ty - , Expression outer commons grp schemas params from ty ) -- ^ bounds - -> Condition outer commons grp schemas params from + = forall grp lat with db params from ty + . Expression grp lat with db params from ty + -> ( Expression grp lat with db params from ty + , Expression grp lat with db params from ty ) -- ^ bounds + -> Condition grp lat with db params from unsafeBetweenExpr :: ByteString -> BetweenExpr unsafeBetweenExpr fun a (x,y) = UnsafeExpression $ @@ -146,7 +151,7 @@ >>> printSQL $ true `isDistinctFrom` null_ (TRUE IS DISTINCT FROM NULL) -} -isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) +isDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM" {- | equal, treating null like an ordinary value @@ -154,7 +159,7 @@ >>> printSQL $ true `isNotDistinctFrom` null_ (TRUE IS NOT DISTINCT FROM NULL) -} -isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool) +isNotDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM" {- | is true @@ -162,45 +167,45 @@ >>> printSQL $ true & isTrue (TRUE IS TRUE) -} -isTrue :: null0 'PGbool :--> null1 'PGbool -isTrue = unsafeUnaryOpR "IS TRUE" +isTrue :: null0 'PGbool --> null1 'PGbool +isTrue = unsafeRightOp "IS TRUE" {- | is false or unknown >>> printSQL $ true & isNotTrue (TRUE IS NOT TRUE) -} -isNotTrue :: null0 'PGbool :--> null1 'PGbool -isNotTrue = unsafeUnaryOpR "IS NOT TRUE" +isNotTrue :: null0 'PGbool --> null1 'PGbool +isNotTrue = unsafeRightOp "IS NOT TRUE" {- | is false >>> printSQL $ true & isFalse (TRUE IS FALSE) -} -isFalse :: null0 'PGbool :--> null1 'PGbool -isFalse = unsafeUnaryOpR "IS FALSE" +isFalse :: null0 'PGbool --> null1 'PGbool +isFalse = unsafeRightOp "IS FALSE" {- | is true or unknown >>> printSQL $ true & isNotFalse (TRUE IS NOT FALSE) -} -isNotFalse :: null0 'PGbool :--> null1 'PGbool -isNotFalse = unsafeUnaryOpR "IS NOT FALSE" +isNotFalse :: null0 'PGbool --> null1 'PGbool +isNotFalse = unsafeRightOp "IS NOT FALSE" {- | is unknown >>> printSQL $ true & isUnknown (TRUE IS UNKNOWN) -} -isUnknown :: null0 'PGbool :--> null1 'PGbool -isUnknown = unsafeUnaryOpR "IS UNKNOWN" +isUnknown :: null0 'PGbool --> null1 'PGbool +isUnknown = unsafeRightOp "IS UNKNOWN" {- | is true or false >>> printSQL $ true & isNotUnknown (TRUE IS NOT UNKNOWN) -} -isNotUnknown :: null0 'PGbool :--> null1 'PGbool -isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN" +isNotUnknown :: null0 'PGbool --> null1 'PGbool +isNotUnknown = unsafeRightOp "IS NOT UNKNOWN" diff --git a/src/Squeal/PostgreSQL/Expression/Composite.hs b/src/Squeal/PostgreSQL/Expression/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Expression/Composite.hs @@ -0,0 +1,95 @@ +{-| +Module: Squeal.PostgreSQL.Expression.Composite +Description: composite functions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +composite functions +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Expression.Composite + ( -- * Composite Functions + row + , rowStar + , field + ) where + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | A row constructor is an expression that builds a row value +-- (also called a composite value) using values for its member fields. +-- +-- >>> :{ +-- type Complex = 'PGcomposite +-- '[ "real" ::: 'NotNull 'PGfloat8 +-- , "imaginary" ::: 'NotNull 'PGfloat8 ] +-- :} +-- +-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp lat with db params from ('NotNull Complex) +-- >>> printSQL i +-- ROW((0.0 :: float8), (1.0 :: float8)) +row + :: SOP.SListI row + => NP (Aliased (Expression grp lat with db params from)) row + -- ^ zero or more expressions for the row field values + -> Expression grp lat with db params from (null ('PGcomposite row)) +row exprs = UnsafeExpression $ "ROW" <> parenthesized + (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs) + +-- | A row constructor on all columns in a table expression. +rowStar + :: Has tab from row + => Alias tab -- ^ intermediate table + -> Expression grp lat with db params from (null ('PGcomposite row)) +rowStar tab = UnsafeExpression $ "ROW" <> + parenthesized (renderSQL tab <> ".*") + +-- | >>> :{ +-- type Complex = 'PGcomposite +-- '[ "real" ::: 'NotNull 'PGfloat8 +-- , "imaginary" ::: 'NotNull 'PGfloat8 ] +-- type Schema = '["complex" ::: 'Typedef Complex] +-- :} +-- +-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression lat '[] grp (Public Schema) from params ('NotNull Complex) +-- >>> printSQL $ i & field #complex #imaginary +-- (ROW((0.0 :: float8), (1.0 :: float8))::"complex")."imaginary" +field + :: ( relss ~ DbRelations db + , Has sch relss rels + , Has rel rels row + , Has field row ty + ) + => QualifiedAlias sch rel -- ^ row type + -> Alias field -- ^ field name + -> Expression grp lat with db params from ('NotNull ('PGcomposite row)) + -> Expression grp lat with db params from ty +field rel fld expr = UnsafeExpression $ + parenthesized (renderSQL expr <> "::" <> renderSQL rel) + <> "." <> renderSQL fld diff --git a/src/Squeal/PostgreSQL/Expression/Default.hs b/src/Squeal/PostgreSQL/Expression/Default.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Expression/Default.hs @@ -0,0 +1,60 @@ +{-| +Module: Squeal.PostgreSQL.Expression.Default +Description: optional expressions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +optional expressions +-} + +{-# LANGUAGE + DataKinds + , GADTs + , LambdaCase + , OverloadedStrings + , PatternSynonyms + , PolyKinds + , QuantifiedConstraints + , RankNTypes + , TypeOperators +#-} + +module Squeal.PostgreSQL.Expression.Default + ( -- * Default + Optional (..) + , mapOptional + , pattern NotDefault + ) where + +import Data.Kind +import Generics.SOP + +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- | `Optional` is either `Default` or `Set`ting of a value, +-- parameterized by an appropriate `Optionality`. +data Optional (expr :: k -> Type) (ty :: (Optionality, k)) where + -- | Use the `Default` value for a column. + Default :: Optional expr ('Def :=> ty) + -- | `Set` a value for a column. + Set :: expr ty -> Optional expr (def :=> ty) + +instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where + renderSQL = \case + Default -> "DEFAULT" + Set x -> renderSQL x + +-- | Map a function over an `Optional` expression. +mapOptional + :: (expr x -> expr y) + -> Optional expr (def :=> x) + -> Optional expr (def :=> y) +mapOptional f = \case + Default -> Default + Set x -> Set (f x) + +-- | `NotDefault` pattern analagous to `Just`. +pattern NotDefault :: ty -> Optional I ('Def :=> ty) +pattern NotDefault x = Set (I x) diff --git a/src/Squeal/PostgreSQL/Expression/Inline.hs b/src/Squeal/PostgreSQL/Expression/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Expression/Inline.hs @@ -0,0 +1,363 @@ +{-| +Module: Squeal.PostgreSQL.Expression.Inline +Description: inline expressions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +inline expressions +-} + +{-# LANGUAGE + DataKinds + , FlexibleContexts + , FlexibleInstances + , LambdaCase + , MultiParamTypeClasses + , MultiWayIf + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , TypeSynonymInstances + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Expression.Inline + ( -- * Inline + Inline (..) + , InlineParam (..) + , InlineField (..) + , inlineFields + , InlineColumn (..) + , inlineColumns + ) where + +import Data.Binary.Builder (toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec) +import Data.ByteString.Builder.Scientific (scientificBuilder) +import Data.Functor.Const (Const(Const)) +import Data.Functor.Constant (Constant(Constant)) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Type) +import Data.Scientific (Scientific) +import Data.String +import Data.Text (Text) +import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, UTCTime) +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)) +import GHC.TypeLits + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text.Lazy as Lazy.Text +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Record as SOP + +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Array +import Squeal.PostgreSQL.Expression.Default +import Squeal.PostgreSQL.Expression.Composite +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Expression.Null +import Squeal.PostgreSQL.Expression.Range +import Squeal.PostgreSQL.Expression.Time +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.PG +import Squeal.PostgreSQL.Type.Schema + +{- | +The `Inline` class allows embedding a Haskell value directly +as an `Expression` using `inline`. + +>>> printSQL (inline 'a') +(E'a' :: char(1)) + +>>> printSQL (inline (1 :: Double)) +(1.0 :: float8) + +>>> printSQL (inline (Json ([1, 2] :: [Double]))) +('[1.0,2.0]' :: json) + +>>> printSQL (inline (Enumerated GT)) +'GT' +-} +class Inline x where inline :: x -> Expr (null (PG x)) +instance Inline Bool where + inline = \case + True -> true + False -> false +instance JSON.ToJSON x => Inline (Json x) where + inline (Json x) + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . toStrict + . JSON.encode + $ x +instance JSON.ToJSON x => Inline (Jsonb x) where + inline (Jsonb x) + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . toStrict + . JSON.encode + $ x +instance Inline Char where + inline chr = inferredtype . UnsafeExpression $ + "E\'" <> fromString (escape chr) <> "\'" +instance Inline String where inline x = fromString x +instance Inline Int16 where + inline x + = inferredtype + . UnsafeExpression + . toStrict + . toLazyByteString + . int16Dec + $ x +instance Inline Int32 where + inline x + = inferredtype + . UnsafeExpression + . toStrict + . toLazyByteString + . int32Dec + $ x +instance Inline Int64 where + inline x = + if x == minBound + -- For some reason Postgres throws an error with + -- (-9223372036854775808 :: int8) + -- even though it's a valid lowest value for int8 + then inline (x+1) - 1 + else inferredtype + . UnsafeExpression + . toStrict + . toLazyByteString + $ int64Dec x +instance Inline Float where + inline x = inferredtype . UnsafeExpression $ + if isNaN x || isInfinite x + then singleQuotedUtf8 (decimal x) + else decimal x + where + decimal = toStrict . toLazyByteString . floatDec +instance Inline Double where + inline x = inferredtype . UnsafeExpression $ + if isNaN x || isInfinite x + then singleQuotedUtf8 (decimal x) + else decimal x + where + decimal = toStrict . toLazyByteString . doubleDec +instance Inline Scientific where + inline x + = inferredtype + . UnsafeExpression + . toStrict + . toLazyByteString + . scientificBuilder + $ x +instance Inline Text where inline x = fromString . Text.unpack $ x +instance Inline Lazy.Text where inline x = fromString . Lazy.Text.unpack $ x +instance (KnownNat n, 1 <= n) => Inline (VarChar n) where + inline x + = inferredtype + . UnsafeExpression + . escapeQuotedText + . getVarChar + $ x +instance (KnownNat n, 1 <= n) => Inline (FixChar n) where + inline x + = inferredtype + . UnsafeExpression + . escapeQuotedText + . getFixChar + $ x +instance Inline x => Inline (Const x tag) where inline (Const x) = inline x +instance Inline x => Inline (SOP.K x tag) where inline (SOP.K x) = inline x +instance Inline x => Inline (Constant x tag) where + inline (Constant x) = inline x +instance Inline DiffTime where + inline dt = + let + picosecs = diffTimeToPicoseconds dt + (secs,leftover) = picosecs `quotRem` 1000000000000 + microsecs = leftover `quot` 1000000 + in + inferredtype $ + interval_ (fromIntegral secs) Seconds + +! interval_ (fromIntegral microsecs) Microseconds +instance Inline Day where + inline x + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show + $ x +instance Inline UTCTime where + inline x + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show + $ x +instance Inline (TimeOfDay, TimeZone) where + inline x + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . formatShow (timeOfDayAndOffsetFormat ExtendedFormat) + $ x +instance Inline TimeOfDay where + inline x + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show + $ x +instance Inline LocalTime where + inline x + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . fromString + . iso8601Show + $ x +instance Inline (Range Int32) where + inline x = range int4range . fmap (\y -> inline y) $ x +instance Inline (Range Int64) where + inline x = range int8range . fmap (\y -> inline y) $ x +instance Inline (Range Scientific) where + inline x = range numrange . fmap (\y -> inline y) $ x +instance Inline (Range LocalTime) where + inline x = range tsrange . fmap (\y -> inline y) $ x +instance Inline (Range UTCTime) where + inline x = range tstzrange . fmap (\y -> inline y) $ x +instance Inline (Range Day) where + inline x = range daterange . fmap (\y -> inline y) $ x +instance Inline UUID where + inline x + = inferredtype + . UnsafeExpression + . singleQuotedUtf8 + . toASCIIBytes + $ x +instance Inline Money where + inline moolah = inferredtype . UnsafeExpression $ + fromString (show dollars) + <> "." <> fromString (show pennies) + where + (dollars,pennies) = cents moolah `divMod` 100 +instance InlineParam x (NullPG x) + => Inline (VarArray [x]) where + inline (VarArray xs) = array ((\x -> inlineParam x) <$> xs) +instance InlineParam x (NullPG x) + => Inline (VarArray (Vector x)) where + inline (VarArray xs) = array ((\x -> inlineParam x) <$> toList xs) +instance Inline Oid where + inline (Oid o) = inferredtype . UnsafeExpression . fromString $ show o +instance + ( SOP.IsEnumType x + , SOP.HasDatatypeInfo x + ) => Inline (Enumerated x) where + inline (Enumerated x) = + let + gshowConstructor + :: NP SOP.ConstructorInfo xss + -> SOP.SOP SOP.I xss + -> String + gshowConstructor Nil _ = "" + gshowConstructor (constructor :* _) (SOP.SOP (SOP.Z _)) = + SOP.constructorName constructor + gshowConstructor (_ :* constructors) (SOP.SOP (SOP.S xs)) = + gshowConstructor constructors (SOP.SOP xs) + in + UnsafeExpression + . singleQuotedUtf8 + . fromString + . gshowConstructor + (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x))) + . SOP.from + $ x +instance + ( SOP.IsRecord x xs + , SOP.AllZip InlineField xs (RowPG x) + ) => Inline (Composite x) where + inline (Composite x) + = row + . SOP.htrans (SOP.Proxy @InlineField) inlineField + . SOP.toRecord + $ x + +-- | Lifts `Inline` to `NullType`s. +class InlineParam x ty where inlineParam :: x -> Expr ty +instance (Inline x, pg ~ PG x) => InlineParam x ('NotNull pg) where inlineParam = inline +instance (Inline x, pg ~ PG x) => InlineParam (Maybe x) ('Null pg) where + inlineParam x = maybe null_ (\y -> inline y) x + +-- | Lifts `Inline` to fields. +class InlineField + (field :: (Symbol, Type)) + (fieldpg :: (Symbol, NullType)) where + inlineField + :: SOP.P field + -> Aliased (Expression grp lat with db params from) fieldpg +instance (KnownSymbol alias, InlineParam x ty) + => InlineField (alias ::: x) (alias ::: ty) where + inlineField (SOP.P x) = inlineParam x `as` Alias @alias + +-- | Inline a Haskell record as a row of expressions. +inlineFields + :: ( SOP.IsRecord hask fields + , SOP.AllZip InlineField fields row ) + => hask -- ^ record + -> NP (Aliased (Expression 'Ungrouped '[] with db params '[])) row +inlineFields + = SOP.htrans (SOP.Proxy @InlineField) inlineField + . SOP.toRecord + + +-- | Lifts `Inline` to a column entry +class InlineColumn + (field :: (Symbol, Type)) + (column :: (Symbol, ColumnType)) where + -- | Haskell record field as a inline column + inlineColumn + :: SOP.P field + -> Aliased (Optional (Expression grp lat with db params from)) column +instance (KnownSymbol col, InlineParam x ty) + => InlineColumn (col ::: x) (col ::: 'NoDef :=> ty) where + inlineColumn (SOP.P x) = Set (inlineParam x) `as` (Alias @col) +instance (KnownSymbol col, InlineParam x ty) + => InlineColumn + (col ::: Optional SOP.I ('Def :=> x)) + (col ::: 'Def :=> ty) where + inlineColumn (SOP.P optional) = case optional of + Default -> Default `as` (Alias @col) + Set (SOP.I x) -> Set (inlineParam x) `as` (Alias @col) + +-- | Inline a Haskell record as a list of columns. +inlineColumns + :: ( SOP.IsRecord hask xs + , SOP.AllZip InlineColumn xs columns ) + => hask -- ^ record + -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns +inlineColumns + = SOP.htrans (SOP.Proxy @InlineColumn) inlineColumn + . SOP.toRecord diff --git a/src/Squeal/PostgreSQL/Expression/Json.hs b/src/Squeal/PostgreSQL/Expression/Json.hs --- a/src/Squeal/PostgreSQL/Expression/Json.hs +++ b/src/Squeal/PostgreSQL/Expression/Json.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Json -Description: Json and Jsonb functions and operators +Description: json and jsonb functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Json and Jsonb functions and operators +json and jsonb functions and operators -} {-# LANGUAGE @@ -25,18 +25,18 @@ #-} module Squeal.PostgreSQL.Expression.Json - ( -- * Json and Jsonb operators + ( -- * Json and Jsonb Operators (.->) , (.->>) , (.#>) , (.#>>) - -- * Jsonb operators + -- * Jsonb Operators , (.?) , (.?|) , (.?&) , (.-.) , (#-.) - -- * Json and Jsonb functions + -- * Json and Jsonb Functions , toJson , toJsonb , arrayToJson @@ -57,11 +57,13 @@ , jsonbSet , jsonbInsert , jsonbPretty - -- * Json and Jsonb set returning functions + -- * Json and Jsonb Set Functions , jsonEach , jsonbEach , jsonEachText + , jsonArrayElementsText , jsonbEachText + , jsonbArrayElementsText , jsonObjectKeys , jsonbObjectKeys , JsonPopulateFunction @@ -79,14 +81,14 @@ import Data.ByteString (ByteString) import GHC.TypeLits -import Squeal.PostgreSQL.Alias +import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.SetOf import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Query.From +import Squeal.PostgreSQL.Query.From.Set import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema import qualified Generics.SOP as SOP @@ -188,7 +190,7 @@ -- otherwise, a scalar value is produced. For any scalar type other than a -- number, a Boolean, or a null value, the text representation will be used, in -- such a fashion that it is a valid json value. -toJson :: null ty :--> null 'PGjson +toJson :: null ty --> null 'PGjson toJson = unsafeFunction "to_json" -- | Returns the value as jsonb. Arrays and composites are converted @@ -197,26 +199,26 @@ -- otherwise, a scalar value is produced. For any scalar type other than a -- number, a Boolean, or a null value, the text representation will be used, in -- such a fashion that it is a valid jsonb value. -toJsonb :: null ty :--> null 'PGjsonb +toJsonb :: null ty --> null 'PGjsonb toJsonb = unsafeFunction "to_jsonb" -- | Returns the array as a JSON array. A PostgreSQL multidimensional array -- becomes a JSON array of arrays. -arrayToJson :: null ('PGvararray ty) :--> null 'PGjson +arrayToJson :: null ('PGvararray ty) --> null 'PGjson arrayToJson = unsafeFunction "array_to_json" -- | Returns the row as a JSON object. -rowToJson :: null ('PGcomposite ty) :--> null 'PGjson +rowToJson :: null ('PGcomposite ty) --> null 'PGjson rowToJson = unsafeFunction "row_to_json" -- | Builds a possibly-heterogeneously-typed JSON array out of a variadic -- argument list. -jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson) +jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson jsonBuildArray = unsafeFunctionN "json_build_array" -- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a -- variadic argument list. -jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb) +jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb jsonbBuildArray = unsafeFunctionN "jsonb_build_array" -- | Builds a possibly-heterogeneously-typed JSON object out of a variadic @@ -224,10 +226,10 @@ -- and values. class SOP.SListI tys => JsonBuildObject tys where - jsonBuildObject :: FunctionN tys (null 'PGjson) + jsonBuildObject :: tys ---> null 'PGjson jsonBuildObject = unsafeFunctionN "json_build_object" - jsonbBuildObject :: FunctionN tys (null 'PGjsonb) + jsonbBuildObject :: tys ---> null 'PGjsonb jsonbBuildObject = unsafeFunctionN "jsonb_build_object" instance JsonBuildObject '[] @@ -240,7 +242,7 @@ -- which are taken as a key/value pair. jsonObject :: null ('PGfixarray '[n,2] ('NotNull 'PGtext)) - :--> null 'PGjson + --> null 'PGjson jsonObject = unsafeFunction "json_object" -- | Builds a binary JSON object out of a text array. @@ -249,24 +251,24 @@ -- which are taken as a key/value pair. jsonbObject :: null ('PGfixarray '[n,2] ('NotNull 'PGtext)) - :--> null 'PGjsonb + --> null 'PGjsonb jsonbObject = unsafeFunction "jsonb_object" -- | This is an alternate form of 'jsonObject' that takes two arrays; one for -- keys and one for values, that are zipped pairwise to create a JSON object. -jsonZipObject :: FunctionN +jsonZipObject :: '[ null ('PGvararray ('NotNull 'PGtext)) , null ('PGvararray ('NotNull 'PGtext)) ] - ( null 'PGjson ) + ---> null 'PGjson jsonZipObject = unsafeFunctionN "json_object" -- | This is an alternate form of 'jsonbObject' that takes two arrays; one for -- keys and one for values, that are zipped pairwise to create a binary JSON -- object. -jsonbZipObject :: FunctionN +jsonbZipObject :: '[ null ('PGvararray ('NotNull 'PGtext)) , null ('PGvararray ('NotNull 'PGtext)) ] - ( null 'PGjsonb ) + ---> null 'PGjsonb jsonbZipObject = unsafeFunctionN "jsonb_object" {----------------------------------------- @@ -274,31 +276,31 @@ -----------------------------------------} -- | Returns the number of elements in the outermost JSON array. -jsonArrayLength :: null 'PGjson :--> null 'PGint4 +jsonArrayLength :: null 'PGjson --> null 'PGint4 jsonArrayLength = unsafeFunction "json_array_length" -- | Returns the number of elements in the outermost binary JSON array. -jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4 +jsonbArrayLength :: null 'PGjsonb --> null 'PGint4 jsonbArrayLength = unsafeFunction "jsonb_array_length" -- | Returns the type of the outermost JSON value as a text string. Possible -- types are object, array, string, number, boolean, and null. -jsonTypeof :: null 'PGjson :--> null 'PGtext +jsonTypeof :: null 'PGjson --> null 'PGtext jsonTypeof = unsafeFunction "json_typeof" -- | Returns the type of the outermost binary JSON value as a text string. -- Possible types are object, array, string, number, boolean, and null. -jsonbTypeof :: null 'PGjsonb :--> null 'PGtext +jsonbTypeof :: null 'PGjsonb --> null 'PGtext jsonbTypeof = unsafeFunction "jsonb_typeof" -- | Returns its argument with all object fields that have null values omitted. -- Other null values are untouched. -jsonStripNulls :: null 'PGjson :--> null 'PGjson +jsonStripNulls :: null 'PGjson --> null 'PGjson jsonStripNulls = unsafeFunction "json_strip_nulls" -- | Returns its argument with all object fields that have null values omitted. -- Other null values are untouched. -jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb +jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb jsonbStripNulls = unsafeFunction "jsonb_strip_nulls" -- | @ jsonbSet target path new_value create_missing @ @@ -309,12 +311,9 @@ -- item designated by path does not exist. As with the path orientated -- operators, negative integers that appear in path count from the end of JSON -- arrays. -jsonbSet - :: FunctionN - '[ null 'PGjsonb - , null ('PGvararray ('NotNull 'PGtext)) - , null 'PGjsonb - , null 'PGbool ] (null 'PGjsonb) +jsonbSet :: + '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext)) + , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb jsonbSet = unsafeFunctionN "jsonbSet" -- | @ jsonbInsert target path new_value insert_after @ @@ -326,86 +325,102 @@ -- path is in JSONB object, @new_value@ will be inserted only if target does not -- exist. As with the path orientated operators, negative integers that appear -- in path count from the end of JSON arrays. -jsonbInsert - :: FunctionN - '[ null 'PGjsonb - , null ('PGvararray ('NotNull 'PGtext)) - , null 'PGjsonb - , null 'PGbool ] (null 'PGjsonb) +jsonbInsert :: + '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext)) + , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb jsonbInsert = unsafeFunctionN "jsonb_insert" -- | Returns its argument as indented JSON text. -jsonbPretty :: null 'PGjsonb :--> null 'PGtext +jsonbPretty :: null 'PGjsonb --> null 'PGtext jsonbPretty = unsafeFunction "jsonb_pretty" - {- | Expands the outermost JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json)) +>>> printSQL (select Star (from (jsonEach (inline (Json (object ["a" .= "foo"])))))) +SELECT * FROM json_each(('{"a":"foo"}' :: json)) -} -jsonEach :: SetOfFunction "json_each" (null 'PGjson) - '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson] -jsonEach = unsafeSetOfFunction +jsonEach :: null 'PGjson -|-> + ("json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]) +jsonEach = unsafeSetFunction "json_each" {- | Expands the outermost binary JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb)) +>>> printSQL (select Star (from (jsonbEach (inline (Jsonb (object ["a" .= "foo"])))))) +SELECT * FROM jsonb_each(('{"a":"foo"}' :: jsonb)) -} jsonbEach - :: SetOfFunction "jsonb_each" (nullity 'PGjsonb) - '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson] -jsonbEach = unsafeSetOfFunction + :: null 'PGjsonb -|-> + ("jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]) +jsonbEach = unsafeSetFunction "jsonb_each" {- | Expands the outermost JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json)) +>>> printSQL (select Star (from (jsonEachText (inline (Json (object ["a" .= "foo"])))))) +SELECT * FROM json_each_text(('{"a":"foo"}' :: json)) -} jsonEachText - :: SetOfFunction "json_each_text" (null 'PGjson) - '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext] -jsonEachText = unsafeSetOfFunction + :: null 'PGjson -|-> + ("json_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]) +jsonEachText = unsafeSetFunction "json_each_text" +{- | Returns a set of text values from a JSON array + +>>> printSQL (select Star (from (jsonArrayElementsText (inline (Json (toJSON ["monkey", "pony", "bear"] )))))) +SELECT * FROM json_array_elements_text(('["monkey","pony","bear"]' :: json)) +-} +jsonArrayElementsText + :: null 'PGjson -|-> + ("json_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext]) +jsonArrayElementsText = unsafeSetFunction "json_array_elements_text" + {- | Expands the outermost binary JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb)) +>>> printSQL (select Star (from (jsonbEachText (inline (Jsonb (object ["a" .= "foo"])))))) +SELECT * FROM jsonb_each_text(('{"a":"foo"}' :: jsonb)) -} jsonbEachText - :: SetOfFunction "jsonb_each_text" (null 'PGjsonb) - '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext] -jsonbEachText = unsafeSetOfFunction + :: null 'PGjsonb -|-> + ("jsonb_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]) +jsonbEachText = unsafeSetFunction "jsonb_each_text" {- | Returns set of keys in the outermost JSON object. ->>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"])))) -json_object_keys(('{"a":"foo","b":"bar"}' :: json)) +>>> printSQL (jsonObjectKeys (inline (Json (object ["a" .= "foo"])))) +json_object_keys(('{"a":"foo"}' :: json)) -} jsonObjectKeys - :: SetOfFunction "json_object_keys" (nullity 'PGjson) - '["json_object_keys" ::: 'NotNull 'PGtext] -jsonObjectKeys = unsafeSetOfFunction + :: null 'PGjson -|-> + ("json_object_keys" ::: '["json_object_keys" ::: 'NotNull 'PGtext]) +jsonObjectKeys = unsafeSetFunction "json_object_keys" {- | Returns set of keys in the outermost JSON object. ->>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"])))) -jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb)) +>>> printSQL (jsonbObjectKeys (inline (Jsonb (object ["a" .= "foo"])))) +jsonb_object_keys(('{"a":"foo"}' :: jsonb)) -} jsonbObjectKeys - :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb) - '["jsonb_object_keys" ::: 'NotNull 'PGtext] -jsonbObjectKeys = unsafeSetOfFunction + :: null 'PGjsonb -|-> + ("jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext]) +jsonbObjectKeys = unsafeSetFunction "jsonb_object_keys" +{- | Returns a set of text values from a binary JSON array + +>>> printSQL (select Star (from (jsonbArrayElementsText (inline (Jsonb (toJSON ["red", "green", "cyan"] )))))) +SELECT * FROM jsonb_array_elements_text(('["red","green","cyan"]' :: jsonb)) +-} +jsonbArrayElementsText + :: null 'PGjsonb -|-> + ("jsonb_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext]) +jsonbArrayElementsText = unsafeSetFunction "jsonb_array_elements_text" + -- | Build rows from Json types. type JsonPopulateFunction fun json - = forall schemas row outer commons params + = forall db row lat with params . json `In` PGJsonType - => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type - -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json) + => TypeExpression db ('NotNull ('PGcomposite row)) -- ^ row type + -> Expression 'Ungrouped lat with db params '[] ('NotNull json) -- ^ json type - -> FromClause outer commons schemas params '[fun ::: row] + -> FromClause lat with db params '[fun ::: row] unsafePopulateFunction :: forall fun ty @@ -436,20 +451,20 @@ -- | Build rows from Json types. type JsonToRecordFunction json - = forall outer commons schemas params tab row + = forall lat with db params tab row . (SOP.SListI row, json `In` PGJsonType) - => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json) + => Expression 'Ungrouped lat with db params '[] ('NotNull json) -- ^ json type - -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row) + -> Aliased (NP (Aliased (TypeExpression db))) (tab ::: row) -- ^ row type - -> FromClause outer commons schemas params '[tab ::: row] + -> FromClause lat with db params '[tab ::: row] unsafeRecordFunction :: ByteString -> JsonToRecordFunction json unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $ fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab <> parenthesized (renderCommaSeparated renderTy types) where - renderTy :: Aliased (TypeExpression schemas) ty -> ByteString + renderTy :: Aliased (TypeExpression db) ty -> ByteString renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty -- | Builds an arbitrary record from a JSON object. diff --git a/src/Squeal/PostgreSQL/Expression/Literal.hs b/src/Squeal/PostgreSQL/Expression/Literal.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Expression/Literal.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Literal -Description: Literal expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Literal expressions --} - -{-# LANGUAGE - FlexibleContexts - , FlexibleInstances - , LambdaCase - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeSynonymInstances - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where - -import ByteString.StrictBuilder (builderBytes) -import Data.ByteString.Lazy (toStrict) -import Data.Int -import Data.String -import Data.Text (Text) - -import qualified Data.Aeson as JSON -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text.Lazy as Lazy.Text - -import Squeal.PostgreSQL.Binary -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.PG -import Squeal.PostgreSQL.Render - -{- | -The `Literal` class allows embedding a Haskell value directly -as an `Expression` using `literal`. - ->>> printSQL (literal 'a') -E'a' - ->>> printSQL (literal (1 :: Double)) -1.0 - ->>> printSQL (literal (Json [1 :: Double, 2])) -('[1.0,2.0]' :: json) - ->>> printSQL (literal (Enumerated GT)) -'GT' --} -class Literal hask where literal :: hask -> Expr (null (PG hask)) -instance Literal Bool where - literal = \case - True -> true - False -> false -instance JSON.ToJSON hask => Literal (Json hask) where - literal = UnsafeExpression . parenthesized . (<> " :: json") - . singleQuotedUtf8 . toStrict . JSON.encode . getJson -instance JSON.ToJSON hask => Literal (Jsonb hask) where - literal = UnsafeExpression . parenthesized . (<> " :: jsonb") - . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb -instance Literal Char where - literal chr = UnsafeExpression $ - "E\'" <> fromString (escape chr) <> "\'" -instance Literal String where literal = fromString -instance Literal Int16 where literal = fromIntegral -instance Literal Int32 where literal = fromIntegral -instance Literal Int64 where literal = fromIntegral -instance Literal Float where literal = fromRational . toRational -instance Literal Double where literal = fromRational . toRational -instance Literal Text where literal = fromString . Text.unpack -instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack -instance ToParam (Enumerated enum) (PG (Enumerated enum)) - => Literal (Enumerated enum) where - literal - = UnsafeExpression - . singleQuotedUtf8 - . builderBytes - . unK - . toParam @(Enumerated enum) @(PG (Enumerated enum)) diff --git a/src/Squeal/PostgreSQL/Expression/Logic.hs b/src/Squeal/PostgreSQL/Expression/Logic.hs --- a/src/Squeal/PostgreSQL/Expression/Logic.hs +++ b/src/Squeal/PostgreSQL/Expression/Logic.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Logic -Description: Logical expressions +Description: logical expressions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Logical expressions and operators +logical expressions and operators -} {-# LANGUAGE @@ -15,25 +15,28 @@ #-} module Squeal.PostgreSQL.Expression.Logic - ( Condition + ( -- * Condition + Condition , true , false + -- * Logic , not_ , (.&&) , (.||) + -- * Conditional , caseWhenThenElse , ifThenElse ) where import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- | A `Condition` is an `Expression`, which can evaluate -- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses -- a three valued logic. -type Condition outer commons grp schemas params from = - Expression outer commons grp schemas params from ('Null 'PGbool) +type Condition grp lat with db params from = + Expression grp lat with db params from ('Null 'PGbool) -- | >>> printSQL true -- TRUE @@ -47,8 +50,8 @@ -- | >>> printSQL $ not_ true -- (NOT TRUE) -not_ :: null 'PGbool :--> null 'PGbool -not_ = unsafeUnaryOpL "NOT" +not_ :: null 'PGbool --> null 'PGbool +not_ = unsafeLeftOp "NOT" -- | >>> printSQL $ true .&& false -- (TRUE AND FALSE) @@ -64,19 +67,19 @@ -- | >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGint2) +-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 -- in printSQL expression -- :} --- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END +-- CASE WHEN TRUE THEN (1 :: int2) WHEN FALSE THEN (2 :: int2) ELSE (3 :: int2) END caseWhenThenElse - :: [ ( Condition outer commons grp schemas params from - , Expression outer commons grp schemas params from ty + :: [ ( Condition grp lat with db params from + , Expression grp lat with db params from ty ) ] -- ^ whens and thens - -> Expression outer commons grp schemas params from ty + -> Expression grp lat with db params from ty -- ^ else - -> Expression outer commons grp schemas params from ty + -> Expression grp lat with db params from ty caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat [ "CASE" , mconcat @@ -92,14 +95,14 @@ -- | >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGint2) +-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = ifThenElse true 1 0 -- in printSQL expression -- :} --- CASE WHEN TRUE THEN 1 ELSE 0 END +-- CASE WHEN TRUE THEN (1 :: int2) ELSE (0 :: int2) END ifThenElse - :: Condition outer commons grp schemas params from - -> Expression outer commons grp schemas params from ty -- ^ then - -> Expression outer commons grp schemas params from ty -- ^ else - -> Expression outer commons grp schemas params from ty + :: Condition grp lat with db params from + -> Expression grp lat with db params from ty -- ^ then + -> Expression grp lat with db params from ty -- ^ else + -> Expression grp lat with db params from ty ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ diff --git a/src/Squeal/PostgreSQL/Expression/Math.hs b/src/Squeal/PostgreSQL/Expression/Math.hs --- a/src/Squeal/PostgreSQL/Expression/Math.hs +++ b/src/Squeal/PostgreSQL/Expression/Math.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Math -Description: Math expressions +Description: math functions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Mathematical functions and operators +math functions -} {-# LANGUAGE @@ -15,7 +15,8 @@ #-} module Squeal.PostgreSQL.Expression.Math - ( atan2_ + ( -- * Math Function + atan2_ , quot_ , rem_ , trunc @@ -24,8 +25,8 @@ ) where import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -36,10 +37,8 @@ -- expression = atan2_ (pi *: 2) -- in printSQL expression -- :} --- atan2(pi(), 2) -atan2_ - :: float `In` PGFloating - => FunctionN '[ null float, null float] (null float) +-- atan2(pi(), (2.0 :: float4)) +atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float atan2_ = unsafeFunctionN "atan2" @@ -47,11 +46,11 @@ -- -- >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGint2) +-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = 5 `quot_` 2 -- in printSQL expression -- :} --- (5 / 2) +-- ((5 :: int2) / (2 :: int2)) quot_ :: int `In` PGIntegral => Operator (null int) (null int) (null int) @@ -61,11 +60,11 @@ -- -- >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGint2) +-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = 5 `rem_` 2 -- in printSQL expression -- :} --- (5 % 2) +-- ((5 :: int2) % (2 :: int2)) rem_ :: int `In` PGIntegral => Operator (null int) (null int) (null int) @@ -73,30 +72,30 @@ -- | >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGfloat4) +-- expression :: Expression grp lat with db params from (null 'PGfloat4) -- expression = trunc pi -- in printSQL expression -- :} -- trunc(pi()) -trunc :: frac `In` PGFloating => null frac :--> null frac +trunc :: frac `In` PGFloating => null frac --> null frac trunc = unsafeFunction "trunc" -- | >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGfloat4) +-- expression :: Expression grp lat with db params from (null 'PGfloat4) -- expression = round_ pi -- in printSQL expression -- :} -- round(pi()) -round_ :: frac `In` PGFloating => null frac :--> null frac +round_ :: frac `In` PGFloating => null frac --> null frac round_ = unsafeFunction "round" -- | >>> :{ -- let --- expression :: Expression outer commons grp schemas params from (null 'PGfloat4) +-- expression :: Expression grp lat with db params from (null 'PGfloat4) -- expression = ceiling_ pi -- in printSQL expression -- :} -- ceiling(pi()) -ceiling_ :: frac `In` PGFloating => null frac :--> null frac +ceiling_ :: frac `In` PGFloating => null frac --> null frac ceiling_ = unsafeFunction "ceiling" 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 @@ -1,34 +1,43 @@ {-| Module: Squeal.PostgreSQL.Expression.Null -Description: Null +Description: null expressions and handlers Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Null values and null handling functions +null expressions and handlers -} {-# LANGUAGE DataKinds + , KindSignatures , OverloadedStrings + , RankNTypes + , TypeFamilies , TypeOperators #-} module Squeal.PostgreSQL.Expression.Null - ( null_ - , notNull + ( -- * Null + null_ + , just_ + , unsafeNotNull + , monoNotNull , coalesce , fromNull , isNull , isNotNull , matchNull , nullIf + , CombineNullity + -- deprecated + , notNull ) where import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -42,16 +51,37 @@ -- | analagous to `Just` -- --- >>> printSQL $ notNull true +-- >>> printSQL $ just_ true -- TRUE -notNull :: 'NotNull ty :--> 'Null ty +just_ :: 'NotNull ty --> 'Null ty +just_ = UnsafeExpression . renderSQL + +-- | analagous to `Just` +{-# DEPRECATED notNull "use just_ instead" #-} +notNull :: 'NotNull ty --> 'Null ty notNull = UnsafeExpression . renderSQL +-- | Analagous to `Data.Maybe.fromJust` inverse to `notNull`, +-- useful when you know an `Expression` is `NotNull`, +-- because, for instance, you've filtered out @NULL@ +-- values in a column. +unsafeNotNull :: 'Null ty --> 'NotNull ty +unsafeNotNull = UnsafeExpression . renderSQL + +-- | Some expressions are null polymorphic which may raise +-- inference issues. Use `monoNotNull` to fix their +-- 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 x = x + -- | return the leftmost value which is not NULL -- -- >>> printSQL $ coalesce [null_, true] false -- COALESCE(NULL, TRUE, FALSE) -coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty) +coalesce :: FunctionVar ('Null ty) (null ty) (null ty) coalesce nullxs notNullx = UnsafeExpression $ "COALESCE" <> parenthesized (commaSeparated ((renderSQL <$> nullxs) <> [renderSQL notNullx])) @@ -61,20 +91,20 @@ -- >>> printSQL $ fromNull true null_ -- COALESCE(NULL, TRUE) fromNull - :: Expression outer commons grp schemas params from ('NotNull ty) + :: Expression grp lat with db params from ('NotNull ty) -- ^ what to convert @NULL@ to - -> Expression outer commons grp schemas params from ('Null ty) - -> Expression outer commons grp schemas params from ('NotNull ty) + -> Expression grp lat with db params from ('Null ty) + -> Expression grp lat with db params from ('NotNull ty) fromNull notNullx nullx = coalesce [nullx] notNullx -- | >>> printSQL $ null_ & isNull -- NULL IS NULL -isNull :: 'Null ty :--> null 'PGbool +isNull :: 'Null ty --> null 'PGbool isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL" -- | >>> printSQL $ null_ & isNotNull -- NULL IS NOT NULL -isNotNull :: 'Null ty :--> null 'PGbool +isNotNull :: 'Null ty --> null 'PGbool isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@ @@ -82,23 +112,30 @@ -- >>> printSQL $ matchNull true not_ null_ -- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END matchNull - :: Expression outer commons grp schemas params from (nullty) + :: Expression grp lat with db params from (nullty) -- ^ what to convert @NULL@ to - -> ( Expression outer commons grp schemas params from ('NotNull ty) - -> Expression outer commons grp schemas params from (nullty) ) + -> ( Expression grp lat with db params from ('NotNull ty) + -> Expression grp lat with db params from (nullty) ) -- ^ function to perform when @NULL@ is absent - -> Expression outer commons grp schemas params from ('Null ty) - -> Expression outer commons grp schemas params from (nullty) + -> Expression grp lat with db params from ('Null ty) + -> Expression grp lat with db params from (nullty) matchNull y f x = ifThenElse (isNull x) y (f (UnsafeExpression (renderSQL x))) {-| right inverse to `fromNull`, if its arguments are equal then `nullIf` gives @NULL@. ->>> :set -XTypeApplications -XDataKinds ->>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool) ->>> printSQL expr +>>> :set -XTypeApplications +>>> printSQL (nullIf (false *: param @1)) NULLIF(FALSE, ($1 :: bool)) -} -nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty) +nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty nullIf = unsafeFunctionN "NULLIF" + +{-| Make the return type of the type family `NotNull` if both arguments are, + or `Null` otherwise. +-} +type family CombineNullity + (lhs :: PGType -> NullType) (rhs :: PGType -> NullType) :: PGType -> NullType where + CombineNullity 'NotNull 'NotNull = 'NotNull + CombineNullity _ _ = 'Null diff --git a/src/Squeal/PostgreSQL/Expression/Parameter.hs b/src/Squeal/PostgreSQL/Expression/Parameter.hs --- a/src/Squeal/PostgreSQL/Expression/Parameter.hs +++ b/src/Squeal/PostgreSQL/Expression/Parameter.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Parameter -Description: Parameters +Description: out-of-line parameters Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Parameters, out-of-line data values +out-of-line parameters -} {-# LANGUAGE @@ -14,67 +14,120 @@ , FlexibleContexts , FlexibleInstances , FunctionalDependencies + , GADTs , KindSignatures , MultiParamTypeClasses , OverloadedStrings , RankNTypes , ScopedTypeVariables , TypeApplications + , TypeFamilies , TypeOperators , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Parameter - ( HasParameter (parameter) + ( -- * Parameter + HasParameter (parameter) , param + -- * Parameter Internals + , HasParameter' + , ParamOutOfBoundsError + , ParamTypeMismatchError ) where +import Data.Kind (Constraint) +import GHC.Exts (Any) import GHC.TypeLits import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Type import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL {- | A `HasParameter` constraint is used to indicate a value that is supplied externally to a SQL statement. -`Squeal.PostgreSQL.PQ.manipulateParams`, -`Squeal.PostgreSQL.PQ.queryParams` and -`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values +`Squeal.PostgreSQL.Session.manipulateParams`, +`Squeal.PostgreSQL.Session.queryParams` and +`Squeal.PostgreSQL.Session.traversePrepared` support specifying data values separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -} -class KnownNat n => HasParameter - (n :: Nat) - (params :: [NullityType]) - (ty :: NullityType) - | n params -> ty where +class KnownNat ix => HasParameter + (ix :: Nat) + (params :: [NullType]) + (ty :: NullType) + | ix params -> ty where -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. -- - -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4) - -- >>> printSQL expr + -- >>> printSQL (parameter @1 int4) -- ($1 :: int4) parameter - :: TypeExpression schemas ty - -> Expression outer commons grp schemas params from ty + :: TypeExpression db ty + -> Expression grp lat with db params from ty parameter ty = UnsafeExpression $ parenthesized $ - "$" <> renderNat @n <+> "::" + "$" <> renderNat @ix <+> "::" <+> renderSQL ty -instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1 -instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty) - => HasParameter n (ty' : params) ty +-- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating, +-- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@ +instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x +instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x + +-- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to +-- include the full parameter list in our errors. +class KnownNat ix => HasParameter' + (originalIx :: Nat) + (allParams :: [NullType]) + (ix :: Nat) + (params :: [NullType]) + (ty :: NullType) + | ix params -> ty where +instance {-# OVERLAPS #-} + ( params ~ (y ': xs) + , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError' + , ParamOutOfBoundsError originalIx allParams params + , ParamTypeMismatchError originalIx allParams x y + ) => HasParameter' originalIx allParams 1 params x +instance {-# OVERLAPS #-} + ( KnownNat ix + , HasParameter' originalIx allParams (ix-1) xs x + , params ~ (y ': xs) + , ParamOutOfBoundsError originalIx allParams params + ) + => HasParameter' originalIx allParams ix params x + +-- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but +-- find a different field than we expected, or when we find ourself out of bounds +type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where + ParamOutOfBoundsError originalIx allParams '[] = TypeError + ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams) + ParamOutOfBoundsError _ _ _ = () + +-- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but +-- find a different field than we expected, or when we find ourself out of bounds +type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where + ParamTypeMismatchError _ _ found found = () + ParamTypeMismatchError originalIx allParams found expected = TypeError + ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx + ':$$: 'Text "in 1-indexed parameter list:" + ':$$: 'Text " " ':<>: 'ShowType allParams + ':$$: 'Text "" + ':$$: 'Text "Expected: " ':<>: 'ShowType expected + ':$$: 'Text "But found: " ':<>: 'ShowType found + ':$$: 'Text "" + ) + -- | `param` takes a `Nat` using type application and for basic types, -- infers a `TypeExpression`. -- --- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4) --- >>> printSQL expr +-- >>> printSQL (param @1 @('Null 'PGint4)) -- ($1 :: int4) param - :: forall n outer commons schemas params from grp ty - . (PGTyped schemas ty, HasParameter n params ty) - => Expression outer commons grp schemas params from ty -- ^ param -param = parameter @n (pgtype @schemas) + :: forall n ty lat with db params from grp + . (NullTyped db ty, HasParameter n params ty) + => Expression grp lat with db params from ty -- ^ param +param = parameter @n (nulltype @db) diff --git a/src/Squeal/PostgreSQL/Expression/Range.hs b/src/Squeal/PostgreSQL/Expression/Range.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Expression/Range.hs @@ -0,0 +1,227 @@ +{-| +Module: Squeal.PostgreSQL.Expression.Range +Description: range types and functions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +range types and functions +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , DataKinds + , DeriveAnyClass + , DeriveGeneric + , DeriveFoldable + , DerivingStrategies + , DeriveTraversable + , FlexibleContexts + , FlexibleInstances + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , PatternSynonyms + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Expression.Range + ( -- * Range + Range (..) + , (<=..<=), (<..<), (<=..<), (<..<=) + , moreThan, atLeast, lessThan, atMost + , singleton, whole + , Bound (..) + -- * Range Function + -- ** Range Construction + , range + -- ** Range Operator + , (.<@) + , (@>.) + , (<<@) + , (@>>) + , (&<) + , (&>) + , (-|-) + , (@+) + , (@*) + , (@-) + -- ** Range Function + , lowerBound + , upperBound + , isEmpty + , lowerInc + , lowerInf + , upperInc + , upperInf + , rangeMerge + ) where + +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Type hiding (bool) +import Squeal.PostgreSQL.Type.PG +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL (tstzrange, numrange, int4range, now, printSQL) + +-- | Construct a `range` +-- +-- >>> printSQL $ range tstzrange (atLeast now) +-- tstzrange(now(), NULL, '[)') +-- >>> printSQL $ range numrange (0 <=..< 2*pi) +-- numrange((0.0 :: numeric), ((2.0 :: numeric) * pi()), '[)') +-- >>> printSQL $ range int4range Empty +-- ('empty' :: int4range) +range + :: TypeExpression db (null ('PGrange ty)) + -- ^ range type + -> Range (Expression grp lat with db params from ('NotNull ty)) + -- ^ range of values + -> Expression grp lat with db params from (null ('PGrange ty)) +range ty = \case + Empty -> UnsafeExpression $ parenthesized + (emp <+> "::" <+> renderSQL ty) + NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized + (commaSeparated (args l u)) + where + emp = singleQuote <> "empty" <> singleQuote + args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote] + singleQuote = "\'" + arg = \case + Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x + bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "(" + ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")" + +-- | The type of `Bound` for a `Range`. +data Bound x + = Infinite -- ^ unbounded + | Closed x -- ^ inclusive + | Open x -- ^ exclusive + deriving + ( Eq, Ord, Show, Read, GHC.Generic + , Functor, Foldable, Traversable ) + +-- | A `Range` datatype that comprises connected subsets of +-- the real line. +data Range x = Empty | NonEmpty (Bound x) (Bound x) + deriving + ( Eq, Ord, Show, Read, GHC.Generic + , Functor, Foldable, Traversable ) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +-- | `PGrange` @(@`PG` @hask)@ +instance IsPG hask => IsPG (Range hask) where + type PG (Range hask) = 'PGrange (PG hask) + +-- | Finite `Range` constructor +(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x +infix 4 <=..<=, <..<, <=..<, <..<= +x <=..<= y = NonEmpty (Closed x) (Closed y) +x <..< y = NonEmpty (Open x) (Open y) +x <=..< y = NonEmpty (Closed x) (Open y) +x <..<= y = NonEmpty (Open x) (Closed y) + +-- | Half-infinite `Range` constructor +moreThan, atLeast, lessThan, atMost :: x -> Range x +moreThan x = NonEmpty (Open x) Infinite +atLeast x = NonEmpty (Closed x) Infinite +lessThan x = NonEmpty Infinite (Open x) +atMost x = NonEmpty Infinite (Closed x) + +-- | A point on the line +singleton :: x -> Range x +singleton x = x <=..<= x + +-- | The `whole` line +whole :: Range x +whole = NonEmpty Infinite Infinite + +-- | range is contained by +(.<@) :: Operator (null0 ty) (null1 ('PGrange ty)) ('Null 'PGbool) +(.<@) = unsafeBinaryOp "<@" + +-- | contains range +(@>.) :: Operator (null0 ('PGrange ty)) (null1 ty) ('Null 'PGbool) +(@>.) = unsafeBinaryOp "@>" + +-- | strictly left of, +-- return false when an empty range is involved +(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) +(<<@) = unsafeBinaryOp "<<" + +-- | strictly right of, +-- return false when an empty range is involved +(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) +(@>>) = unsafeBinaryOp ">>" + +-- | does not extend to the right of, +-- return false when an empty range is involved +(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) +(&<) = unsafeBinaryOp "&<" + +-- | does not extend to the left of, +-- return false when an empty range is involved +(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) +(&>) = unsafeBinaryOp "&>" + +-- | is adjacent to, return false when an empty range is involved +(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) +(-|-) = unsafeBinaryOp "-|-" + +-- | union, will fail if the resulting range would +-- need to contain two disjoint sub-ranges +(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) +(@+) = unsafeBinaryOp "+" + +-- | intersection +(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) +(@*) = unsafeBinaryOp "*" + +-- | difference, will fail if the resulting range would +-- need to contain two disjoint sub-ranges +(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) +(@-) = unsafeBinaryOp "-" + +-- | lower bound of range +lowerBound :: null ('PGrange ty) --> 'Null ty +lowerBound = unsafeFunction "lower" + +-- | upper bound of range +upperBound :: null ('PGrange ty) --> 'Null ty +upperBound = unsafeFunction "upper" + +-- | is the range empty? +isEmpty :: null ('PGrange ty) --> 'Null 'PGbool +isEmpty = unsafeFunction "isempty" + +-- | is the lower bound inclusive? +lowerInc :: null ('PGrange ty) --> 'Null 'PGbool +lowerInc = unsafeFunction "lower_inc" + +-- | is the lower bound infinite? +lowerInf :: null ('PGrange ty) --> 'Null 'PGbool +lowerInf = unsafeFunction "lower_inf" + +-- | is the upper bound inclusive? +upperInc :: null ('PGrange ty) --> 'Null 'PGbool +upperInc = unsafeFunction "upper_inc" + +-- | is the upper bound infinite? +upperInf :: null ('PGrange ty) --> 'Null 'PGbool +upperInf = unsafeFunction "upper_inf" + +-- | the smallest range which includes both of the given ranges +rangeMerge :: + '[null ('PGrange ty), null ('PGrange ty)] + ---> null ('PGrange ty) +rangeMerge = unsafeFunctionN "range_merge" diff --git a/src/Squeal/PostgreSQL/Expression/SetOf.hs b/src/Squeal/PostgreSQL/Expression/SetOf.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Expression/SetOf.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.SetOf -Description: Set returning functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Set returning functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , FlexibleContexts - , OverloadedStrings - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.SetOf - ( generateSeries - , generateSeriesStep - , generateSeriesTimestamp - , SetOfFunction - , unsafeSetOfFunction - , SetOfFunctionN - , unsafeSetOfFunctionN - ) where - -import GHC.TypeLits - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Schema - -{- | -A @RankNType@ for set returning functions with 1 argument. --} -type SetOfFunction fun ty setof - = forall outer commons schemas params - . Expression outer commons 'Ungrouped schemas params '[] ty - -- ^ input - -> FromClause outer commons schemas params '[fun ::: setof] - -- ^ output - --- | Escape hatch for a set returning function with 1 argument. -unsafeSetOfFunction - :: forall fun ty setof. KnownSymbol fun - => SetOfFunction fun ty setof -- ^ set returning function -unsafeSetOfFunction x = UnsafeFromClause $ - renderSymbol @fun <> parenthesized (renderSQL x) - -{- | -A @RankNType@ for set returning functions with multiple argument. --} -type SetOfFunctionN fun tys setof - = forall outer commons schemas params - . NP (Expression outer commons 'Ungrouped schemas params '[]) tys - -- ^ inputs - -> FromClause outer commons schemas params '[fun ::: setof] - -- ^ output - --- | Escape hatch for a set returning function with multiple argument. -unsafeSetOfFunctionN - :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun) - => SetOfFunctionN fun tys setof -- ^ set returning function -unsafeSetOfFunctionN xs = UnsafeFromClause $ - renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs) - -{- | @generateSeries (start *: stop)@ - -Generate a series of values, from @start@ to @stop@ with a step size of one --} -generateSeries - :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] - => SetOfFunctionN "generate_series" '[ null ty, null ty] - '["generate_series" ::: null ty] -- ^ set returning function -generateSeries = unsafeSetOfFunctionN - -{- | @generateSeries (start :* stop *: step)@ - -Generate a series of values, from @start@ to @stop@ with a step size of @step@ --} -generateSeriesStep - :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] - => SetOfFunctionN "generate_series" '[null ty, null ty, null ty] - '["generate_series" ::: null ty] -- ^ set returning function -generateSeriesStep = unsafeSetOfFunctionN - -{- | @generateSeries (start :* stop *: step)@ - -Generate a series of values, from @start@ to @stop@ with a step size of @step@ --} -generateSeriesTimestamp - :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz] - => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval] - '["generate_series" ::: null ty] -- ^ set returning function -generateSeriesTimestamp = unsafeSetOfFunctionN diff --git a/src/Squeal/PostgreSQL/Expression/Sort.hs b/src/Squeal/PostgreSQL/Expression/Sort.hs --- a/src/Squeal/PostgreSQL/Expression/Sort.hs +++ b/src/Squeal/PostgreSQL/Expression/Sort.hs @@ -1,29 +1,33 @@ {-| Module: Squeal.PostgreSQL.Expression.Sort -Description: Sort expressions +Description: sort expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Sort expressions +sort expressions -} {-# LANGUAGE DataKinds + , FlexibleInstances + , FunctionalDependencies , GADTs , LambdaCase + , MultiParamTypeClasses , OverloadedStrings , StandaloneDeriving #-} module Squeal.PostgreSQL.Expression.Sort - ( SortExpression (..) + ( -- * Sort + SortExpression (..) , OrderBy (..) ) where import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- | `SortExpression`s are used by `orderBy` to optionally sort the results -- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc` @@ -36,27 +40,33 @@ -- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to -- determine whether nulls appear before or after non-null values in the sort -- ordering of a `Null` result column. -data SortExpression outer commons grp schemas params from where +data SortExpression grp lat with db params from where Asc - :: Expression outer commons grp schemas params from ('NotNull ty) - -> SortExpression outer commons grp schemas params from + :: Expression grp lat with db params from ('NotNull ty) + -- ^ sort by + -> SortExpression grp lat with db params from Desc - :: Expression outer commons grp schemas params from ('NotNull ty) - -> SortExpression outer commons grp schemas params from + :: Expression grp lat with db params from ('NotNull ty) + -- ^ sort by + -> SortExpression grp lat with db params from AscNullsFirst - :: Expression outer commons grp schemas params from ('Null ty) - -> SortExpression outer commons grp schemas params from + :: Expression grp lat with db params from ('Null ty) + -- ^ sort by + -> SortExpression grp lat with db params from AscNullsLast - :: Expression outer commons grp schemas params from ('Null ty) - -> SortExpression outer commons grp schemas params from + :: Expression grp lat with db params from ('Null ty) + -- ^ sort by + -> SortExpression grp lat with db params from DescNullsFirst - :: Expression outer commons grp schemas params from ('Null ty) - -> SortExpression outer commons grp schemas params from + :: Expression grp lat with db params from ('Null ty) + -- ^ sort by + -> SortExpression grp lat with db params from DescNullsLast - :: Expression outer commons grp schemas params from ('Null ty) - -> SortExpression outer commons grp schemas params from -deriving instance Show (SortExpression outer commons grp schemas params from) -instance RenderSQL (SortExpression outer commons grp schemas params from) where + :: Expression grp lat with db params from ('Null ty) + -- ^ sort by + -> SortExpression grp lat with db params from +deriving instance Show (SortExpression grp lat with db params from) +instance RenderSQL (SortExpression grp lat with db params from) where renderSQL = \case Asc expression -> renderSQL expression <+> "ASC" Desc expression -> renderSQL expression <+> "DESC" @@ -66,6 +76,11 @@ <+> "DESC NULLS FIRST" AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST" DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST" +instance RenderSQL [SortExpression grp lat with db params from] where + renderSQL = \case + [] -> "" + srts -> " ORDER BY" + <+> commaSeparated (renderSQL <$> srts) {- | The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression` @@ -78,8 +93,9 @@ You can also control the order in which rows are processed by window functions using `orderBy` within `Squeal.PostgreSQL.Query.Over`. -} -class OrderBy expr where +class OrderBy expr grp | expr -> grp where orderBy - :: [SortExpression outer commons grp schemas params from] - -> expr outer commons grp schemas params from - -> expr outer commons grp schemas params from + :: [SortExpression grp lat with db params from] + -- ^ sorts + -> expr lat with db params from + -> expr lat with db params from diff --git a/src/Squeal/PostgreSQL/Expression/Subquery.hs b/src/Squeal/PostgreSQL/Expression/Subquery.hs --- a/src/Squeal/PostgreSQL/Expression/Subquery.hs +++ b/src/Squeal/PostgreSQL/Expression/Subquery.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Subquery -Description: Subquery expressions +Description: subquery expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Subquery expressions +subquery expressions -} {-# LANGUAGE @@ -16,20 +16,21 @@ #-} module Squeal.PostgreSQL.Expression.Subquery - ( exists + ( -- * Subquery + exists , in_ , notIn , subAll , subAny ) where -import Squeal.PostgreSQL.Alias +import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.List +import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -47,8 +48,9 @@ at least one row is returned, not all the way to completion. -} exists - :: Query (Join outer from) commons schemas params row - -> Condition outer commons grp schemas params from + :: Query (Join lat from) with db params row + -- ^ subquery + -> Expression grp lat with db params from (null 'PGbool) exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query) {- | @@ -66,10 +68,10 @@ (TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))) -} subAll - :: Expression outer commons grp schemas params from ty1 -- ^ expression + :: Expression grp lat with db params from ty1 -- ^ expression -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery - -> Condition outer commons grp schemas params from + -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery + -> Condition grp lat with db params from subAll expr (?) qry = expr ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry)) @@ -81,13 +83,13 @@ (including the case where the subquery returns no rows). >>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo)) -(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo"))) +((E'foo' :: text) LIKE ANY (SELECT * FROM (VALUES ((E'foobar' :: text))) AS t ("foo"))) -} subAny - :: Expression outer commons grp schemas params from ty1 -- ^ expression + :: Expression grp lat with db params from ty1 -- ^ expression -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery - -> Condition outer commons grp schemas params from + -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery + -> Condition grp lat with db params from subAny expr (?) qry = expr ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry)) @@ -99,9 +101,10 @@ TRUE IN (TRUE, FALSE, NULL) -} in_ - :: Expression outer commons grp schemas params from ty -- ^ expression - -> [Expression outer commons grp schemas params from ty] - -> Condition outer commons grp schemas params from + :: Expression grp lat with db params from ty -- ^ expression + -> [Expression grp lat with db params from ty] + -> Expression grp lat with db params from ('Null 'PGbool) +_ `in_` [] = false expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN" <+> parenthesized (commaSeparated (renderSQL <$> exprs)) @@ -113,8 +116,9 @@ TRUE NOT IN (FALSE, NULL) -} notIn - :: Expression outer commons grp schemas params from ty -- ^ expression - -> [Expression outer commons grp schemas params from ty] - -> Condition outer commons grp schemas params from + :: Expression grp lat with db params from ty -- ^ expression + -> [Expression grp lat with db params from ty] + -> Expression grp lat with db params from ('Null 'PGbool) +_ `notIn` [] = true expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN" <+> parenthesized (commaSeparated (renderSQL <$> exprs)) diff --git a/src/Squeal/PostgreSQL/Expression/Text.hs b/src/Squeal/PostgreSQL/Expression/Text.hs --- a/src/Squeal/PostgreSQL/Expression/Text.hs +++ b/src/Squeal/PostgreSQL/Expression/Text.hs @@ -1,46 +1,51 @@ {-| Module: Squeal.PostgreSQL.Expression.Text -Description: Text expressions +Description: text functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -String functions and operators +text functions and operators -} {-# LANGUAGE DataKinds , OverloadedStrings + , RankNTypes + , ScopedTypeVariables , TypeOperators #-} module Squeal.PostgreSQL.Expression.Text - ( lower + ( -- * Text Function + lower , upper , charLength , like , ilike + , replace + , strpos ) where import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL -- | >>> printSQL $ lower "ARRRGGG" --- lower(E'ARRRGGG') -lower :: null 'PGtext :--> null 'PGtext +-- lower((E'ARRRGGG' :: text)) +lower :: null 'PGtext --> null 'PGtext lower = unsafeFunction "lower" -- | >>> printSQL $ upper "eeee" --- upper(E'eeee') -upper :: null 'PGtext :--> null 'PGtext +-- upper((E'eeee' :: text)) +upper :: null 'PGtext --> null 'PGtext upper = unsafeFunction "upper" -- | >>> printSQL $ charLength "four" --- char_length(E'four') -charLength :: null 'PGtext :--> null 'PGint4 +-- char_length((E'four' :: text)) +charLength :: null 'PGtext --> null 'PGint4 charLength = unsafeFunction "char_length" -- | The `like` expression returns true if the @string@ matches @@ -51,7 +56,7 @@ -- matches any sequence of zero or more characters. -- -- >>> printSQL $ "abc" `like` "a%" --- (E'abc' LIKE E'a%') +-- ((E'abc' :: text) LIKE (E'a%' :: text)) like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) like = unsafeBinaryOp "LIKE" @@ -59,6 +64,25 @@ -- match case-insensitive according to the active locale. -- -- >>> printSQL $ "abc" `ilike` "a%" --- (E'abc' ILIKE E'a%') +-- ((E'abc' :: text) ILIKE (E'a%' :: text)) ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) ilike = unsafeBinaryOp "ILIKE" + +-- | Determines the location of the substring match using the `strpos` +-- function. Returns the 1-based index of the first match, if no +-- match exists the function returns (0). +-- +-- >>> printSQL $ strpos ("string" *: "substring") +-- strpos((E'string' :: text), (E'substring' :: text)) +strpos + :: '[null 'PGtext, null 'PGtext] ---> null 'PGint4 +strpos = unsafeFunctionN "strpos" + +-- | Over the string in the first argument, replace all occurrences of +-- the second argument with the third and return the modified string. +-- +-- >>> printSQL $ replace ("string" :* "from" *: "to") +-- replace((E'string' :: text), (E'from' :: text), (E'to' :: text)) +replace + :: '[ null 'PGtext, null 'PGtext, null 'PGtext ] ---> null 'PGtext +replace = unsafeFunctionN "replace" diff --git a/src/Squeal/PostgreSQL/Expression/TextSearch.hs b/src/Squeal/PostgreSQL/Expression/TextSearch.hs --- a/src/Squeal/PostgreSQL/Expression/TextSearch.hs +++ b/src/Squeal/PostgreSQL/Expression/TextSearch.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.TextSearch -Description: Text search expressions +Description: text search functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Text search functions and operators +text search functions and operators -} {-# LANGUAGE @@ -15,11 +15,13 @@ #-} module Squeal.PostgreSQL.Expression.TextSearch - ( (@@) + ( -- * Text Search Operator + (@@) , (.&) , (.|) , (.!) , (<->) + -- * Text Search Function , arrayToTSvector , tsvectorLength , numnode @@ -39,8 +41,8 @@ ) where import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema -- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ? (@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool) @@ -55,8 +57,8 @@ (.|) = unsafeBinaryOp "||" -- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery` -(.!) :: null 'PGtsquery :--> null 'PGtsquery -(.!) = unsafeUnaryOpL "!!" +(.!) :: null 'PGtsquery --> null 'PGtsquery +(.!) = unsafeLeftOp "!!" -- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by -- `Squeal.PostgreSQL.Expression.Type.tsquery` @@ -66,51 +68,50 @@ -- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector` arrayToTSvector :: null ('PGvararray ('NotNull 'PGtext)) - :--> null 'PGtsvector + --> null 'PGtsvector arrayToTSvector = unsafeFunction "array_to_tsvector" -- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector` -tsvectorLength :: null 'PGtsvector :--> null 'PGint4 +tsvectorLength :: null 'PGtsvector --> null 'PGint4 tsvectorLength = unsafeFunction "length" -- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery` -numnode :: null 'PGtsquery :--> null 'PGint4 +numnode :: null 'PGtsquery --> null 'PGint4 numnode = unsafeFunction "numnode" -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation -plainToTSquery :: null 'PGtext :--> null 'PGtsquery +plainToTSquery :: null 'PGtext --> null 'PGtsquery plainToTSquery = unsafeFunction "plainto_tsquery" -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase, -- ignoring punctuation -phraseToTSquery :: null 'PGtext :--> null 'PGtsquery +phraseToTSquery :: null 'PGtext --> null 'PGtsquery phraseToTSquery = unsafeFunction "phraseto_tsquery" -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query -websearchToTSquery :: null 'PGtext :--> null 'PGtsquery +websearchToTSquery :: null 'PGtext --> null 'PGtsquery websearchToTSquery = unsafeFunction "websearch_to_tsquery" -- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery` -queryTree :: null 'PGtsquery :--> null 'PGtext +queryTree :: null 'PGtsquery --> null 'PGtext queryTree = unsafeFunction "query_tree" -- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery` -toTSquery :: null 'PGtext :--> null 'PGtsquery +toTSquery :: null 'PGtext --> null 'PGtsquery toTSquery = unsafeFunction "to_tsquery" -- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector` toTSvector :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb] - => null ty :--> null 'PGtsvector + => null ty --> null 'PGtsvector toTSvector = unsafeFunction "to_tsvector" -- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector` -setWeight - :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector) +setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector setWeight = unsafeFunctionN "set_weight" -- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector` -strip :: null 'PGtsvector :--> null 'PGtsvector +strip :: null 'PGtsvector --> null 'PGtsvector strip = unsafeFunction "strip" -- | @jsonToTSvector (document *: filter)@ @@ -123,7 +124,7 @@ -- "boolean" (to include all Boolean values in the string format "true"/"false"), -- "key" (to include all keys) or "all" (to include all above). -- These values can be combined together to include, e.g. all string and numeric values. -jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector) +jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector jsonToTSvector = unsafeFunctionN "json_to_tsvector" -- | @jsonbToTSvector (document *: filter)@ @@ -136,23 +137,23 @@ -- "boolean" (to include all Boolean values in the string format "true"/"false"), -- "key" (to include all keys) or "all" (to include all above). -- These values can be combined together to include, e.g. all string and numeric values. -jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector) +jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector" -- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector` -tsDelete :: FunctionN +tsDelete :: '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))] - (null 'PGtsvector) + ---> null 'PGtsvector tsDelete = unsafeFunctionN "ts_delete" -- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector` -tsFilter :: FunctionN +tsFilter :: '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))] - (null 'PGtsvector) + ---> null 'PGtsvector tsFilter = unsafeFunctionN "ts_filter" -- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match tsHeadline :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb] - => FunctionN '[null document, null 'PGtsquery] (null 'PGtext) + => '[null document, null 'PGtsquery] ---> null 'PGtext tsHeadline = unsafeFunctionN "ts_headline" diff --git a/src/Squeal/PostgreSQL/Expression/Time.hs b/src/Squeal/PostgreSQL/Expression/Time.hs --- a/src/Squeal/PostgreSQL/Expression/Time.hs +++ b/src/Squeal/PostgreSQL/Expression/Time.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Time -Description: Date/Time expressions +Description: date/time functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Date/Time functions and operators +date/time functions and operators -} {-# LANGUAGE @@ -17,13 +17,19 @@ , OverloadedStrings , PolyKinds , RankNTypes + , TypeFamilies + , TypeOperators + , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Time - ( TimeOp (..) + ( -- * Time Operation + TimeOp (..) + -- * Time Function , currentDate , currentTime , currentTimestamp + , dateTrunc , localTime , localTimestamp , now @@ -31,18 +37,24 @@ , makeTime , makeTimestamp , makeTimestamptz + , atTimeZone + , PGAtTimeZone + -- * Interval , interval_ , TimeUnit (..) ) where +import Data.Fixed import Data.String +import GHC.TypeLits import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -83,34 +95,29 @@ Create date from year, month and day fields >>> printSQL (makeDate (1984 :* 7 *: 3)) -make_date(1984, 7, 3) +make_date((1984 :: int4), (7 :: int4), (3 :: int4)) -} -makeDate :: FunctionN - '[ null 'PGint4, null 'PGint4, null 'PGint4 ] - ( null 'PGdate ) +makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate makeDate = unsafeFunctionN "make_date" {-| Create time from hour, minute and seconds fields >>> printSQL (makeTime (8 :* 15 *: 23.5)) -make_time(8, 15, 23.5) +make_time((8 :: int4), (15 :: int4), (23.5 :: float8)) -} -makeTime :: FunctionN - '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] - ( null 'PGtime ) +makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime makeTime = unsafeFunctionN "make_time" {-| Create timestamp from year, month, day, hour, minute and seconds fields >>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5)) -make_timestamp(2013, 7, 15, 8, 15, 23.5) +make_timestamp((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) -} -makeTimestamp :: FunctionN +makeTimestamp :: '[ null 'PGint4, null 'PGint4, null 'PGint4 - , null 'PGint4, null 'PGint4, null 'PGfloat8 ] - ( null 'PGtimestamp ) + , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp makeTimestamp = unsafeFunctionN "make_timestamp" {-| @@ -119,39 +126,81 @@ the current time zone is used >>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5)) -make_timestamptz(2013, 7, 15, 8, 15, 23.5) +make_timestamptz((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) -} -makeTimestamptz :: FunctionN +makeTimestamptz :: '[ null 'PGint4, null 'PGint4, null 'PGint4 - , null 'PGint4, null 'PGint4, null 'PGfloat8 ] - ( null 'PGtimestamptz ) + , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz makeTimestamptz = unsafeFunctionN "make_timestamptz" {-| +Truncate a timestamp with the specified precision + +>>> printSQL $ dateTrunc Quarter (makeTimestamp (2010 :* 5 :* 6 :* 14 :* 45 *: 11.4)) +date_trunc('quarter', make_timestamp((2010 :: int4), (5 :: int4), (6 :: int4), (14 :: int4), (45 :: int4), (11.4 :: float8))) +-} +dateTrunc + :: time `In` '[ 'PGtimestamp, 'PGtimestamptz ] + => TimeUnit -> null time --> null time +dateTrunc tUnit args = unsafeFunctionN "date_trunc" (timeUnitExpr *: args) + where + timeUnitExpr :: forall grp lat with db params from null0. + Expression grp lat with db params from (null0 'PGtext) + timeUnitExpr = UnsafeExpression . singleQuotedUtf8 . renderSQL $ tUnit + +-- | Calculate the return time type of the `atTimeZone` `Operator`. +type family PGAtTimeZone ty where + PGAtTimeZone 'PGtimestamptz = 'PGtimestamp + PGAtTimeZone 'PGtimestamp = 'PGtimestamptz + PGAtTimeZone 'PGtimetz = 'PGtimetz + PGAtTimeZone pg = TypeError + ( 'Text "Squeal type error: AT TIME ZONE cannot be applied to " + ':<>: 'ShowType pg ) + +{-| +Convert a timestamp, timestamp with time zone, or time of day with timezone to a different timezone using an interval offset or specific timezone denoted by text. When using the interval offset, the interval duration must be less than one day or 24 hours. + +>>> printSQL $ (makeTimestamp (2009 :* 7 :* 22 :* 19 :* 45 *: 11.4)) `atTimeZone` (interval_ 8 Hours) +(make_timestamp((2009 :: int4), (7 :: int4), (22 :: int4), (19 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (INTERVAL '8.000 hours')) + +>>> :{ + let + timezone :: Expr (null 'PGtext) + timezone = "EST" + in printSQL $ (makeTimestamptz (2015 :* 9 :* 15 :* 4 :* 45 *: 11.4)) `atTimeZone` timezone +:} +(make_timestamptz((2015 :: int4), (9 :: int4), (15 :: int4), (4 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (E'EST' :: text)) +-} +atTimeZone + :: zone `In` '[ 'PGtext, 'PGinterval] + => Operator (null time) (null zone) (null (PGAtTimeZone time)) +atTimeZone = unsafeBinaryOp "AT TIME ZONE" + +{-| Affine space operations on time types. -} class TimeOp time diff | time -> diff where {-| >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365) - (make_date(1984, 7, 3) + 365) + (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) + (365 :: int4)) -} (!+) :: Operator (null time) (null diff) (null time) (!+) = unsafeBinaryOp "+" {-| >>> printSQL (365 +! makeDate (1984 :* 7 *: 3)) - (365 + make_date(1984, 7, 3)) + ((365 :: int4) + make_date((1984 :: int4), (7 :: int4), (3 :: int4))) -} (+!) :: Operator (null diff) (null time) (null time) (+!) = unsafeBinaryOp "+" {-| >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365) - (make_date(1984, 7, 3) - 365) + (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - (365 :: int4)) -} (!-) :: Operator (null time) (null diff) (null time) (!-) = unsafeBinaryOp "-" {-| >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate) - (make_date(1984, 7, 3) - CURRENT_DATE) + (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - CURRENT_DATE) -} (!-!) :: Operator (null time) (null time) (null diff) (!-!) = unsafeBinaryOp "-" @@ -168,7 +217,7 @@ -- | A `TimeUnit` to use in `interval_` construction. data TimeUnit - = Years | Months | Weeks | Days + = Years | Quarter | Months | Weeks | Days | Hours | Minutes | Seconds | Microseconds | Milliseconds | Decades | Centuries | Millennia @@ -178,6 +227,7 @@ instance RenderSQL TimeUnit where renderSQL = \case Years -> "years" + Quarter -> "quarter" Months -> "months" Weeks -> "weeks" Days -> "days" @@ -191,7 +241,7 @@ Millennia -> "millennia" -- | >>> printSQL $ interval_ 7 Days --- (INTERVAL '7.0 days') -interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval) +-- (INTERVAL '7.000 days') +interval_ :: Milli -> TimeUnit -> Expr (null 'PGinterval) interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+> "'" <> fromString (show num) <+> renderSQL unit <> "'" 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 @@ -1,17 +1,18 @@ {-| Module: Squeal.PostgreSQL.Expression -Description: Type expressions +Description: type expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Type expressions. +type expressions -} {-# LANGUAGE AllowAmbiguousTypes , DataKinds , DeriveGeneric + , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs @@ -23,14 +24,18 @@ , ScopedTypeVariables , TypeApplications , TypeOperators + , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Type - ( TypeExpression (..) - , cast + ( -- * Type Cast + cast , astype , inferredtype - , PGTyped (..) + -- * Type Expression + , TypeExpression (..) + , typerow + , typeenum , typedef , typetable , typeview @@ -56,9 +61,11 @@ , bytea , timestamp , timestampWithTimeZone + , timestamptz , date , time , timeWithTimeZone + , timetz , interval , uuid , inet @@ -68,6 +75,33 @@ , fixarray , tsvector , tsquery + , oid + , int4range + , int8range + , numrange + , tsrange + , tstzrange + , daterange + , record + -- * Column Type + , ColumnTypeExpression (..) + , nullable + , notNullable + , default_ + , serial2 + , smallserial + , serial4 + , serial + , serial8 + , bigserial + -- * Type Inference + , PGTyped (..) + , pgtypeFrom + , NullTyped (..) + , nulltypeFrom + , ColumnTyped (..) + , columntypeFrom + , FieldTyped (..) ) where import Control.DeepSeq @@ -79,10 +113,11 @@ import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP -import Squeal.PostgreSQL.Alias +import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -94,24 +129,24 @@ -- | >>> printSQL $ true & cast int4 -- (TRUE :: int4) cast - :: TypeExpression schemas ty1 + :: TypeExpression db ty1 -- ^ type to cast as - -> Expression outer commons grp schemas params from ty0 + -> Expression grp lat with db params from ty0 -- ^ value to convert - -> Expression outer commons grp schemas params from ty1 + -> Expression grp lat with db params from ty1 cast ty x = UnsafeExpression $ parenthesized $ renderSQL x <+> "::" <+> renderSQL ty -- | A safe version of `cast` which just matches a value with its type. -- -- >>> printSQL (1 & astype int) --- (1 :: int) +-- ((1 :: int4) :: int) astype - :: TypeExpression schemas ty + :: TypeExpression db ty -- ^ type to specify as - -> Expression outer commons grp schemas params from ty + -> Expression grp lat with db params from ty -- ^ value - -> Expression outer commons grp schemas params from ty + -> Expression grp lat with db params from ty astype = cast -- | `inferredtype` will add a type annotation to an `Expression` @@ -120,10 +155,11 @@ -- >>> printSQL (inferredtype true) -- (TRUE :: bool) inferredtype - :: PGTyped schemas ty - => Expression outer common grp schemas params from ty - -> Expression outer common grp schemas params from ty -inferredtype = astype pgtype + :: NullTyped db ty + => Expression lat common grp db params from ty + -- ^ value + -> Expression lat common grp db params from ty +inferredtype = astype nulltype {----------------------------------------- type expressions @@ -131,127 +167,158 @@ -- | `TypeExpression`s are used in `cast`s and -- `Squeal.PostgreSQL.Definition.createTable` commands. -newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType) +newtype TypeExpression (db :: SchemasType) (ty :: NullType) = UnsafeTypeExpression { renderTypeExpression :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (TypeExpression schemas ty) where + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (TypeExpression db ty) where renderSQL = renderTypeExpression +-- | The composite type corresponding to a relation can be expressed +-- by its alias. A relation is either a composite type, a table or a view. +-- It subsumes `typetable` and `typeview` and partly overlaps `typedef`. +typerow + :: ( relss ~ DbRelations db + , Has sch relss rels + , Has rel rels row + ) + => QualifiedAlias sch rel + -- ^ type alias + -> TypeExpression db (null ('PGcomposite row)) +typerow = UnsafeTypeExpression . renderSQL + +-- | An enumerated type can be expressed by its alias. +-- `typeenum` is subsumed by `typedef`. +typeenum + :: ( enumss ~ DbEnums db + , Has sch enumss enums + , Has enum enums labels + ) + => QualifiedAlias sch enum + -- ^ type alias + -> TypeExpression db (null ('PGenum labels)) +typeenum = UnsafeTypeExpression . renderSQL + -- | The enum or composite type in a `Typedef` can be expressed by its alias. typedef - :: (Has sch schemas schema, Has td schema ('Typedef ty)) + :: (Has sch db schema, Has td schema ('Typedef ty)) => QualifiedAlias sch td - -> TypeExpression schemas (null ty) + -- ^ type alias + -> TypeExpression db (null ty) typedef = UnsafeTypeExpression . renderSQL -- | The composite type corresponding to a `Table` definition can be expressed --- by its alias. +-- by its alias. It is subsumed by `typerow` typetable - :: (Has sch schemas schema, Has tab schema ('Table table)) + :: (Has sch db schema, Has tab schema ('Table table)) => QualifiedAlias sch tab - -> TypeExpression schemas (null ('PGcomposite (TableToRow table))) + -- ^ table alias + -> TypeExpression db (null ('PGcomposite (TableToRow table))) typetable = UnsafeTypeExpression . renderSQL -- | The composite type corresponding to a `View` definition can be expressed --- by its alias. +-- by its alias. It is subsumed by `typerow`. typeview - :: (Has sch schemas schema, Has vw schema ('View view)) + :: (Has sch db schema, Has vw schema ('View view)) => QualifiedAlias sch vw - -> TypeExpression schemas (null ('PGcomposite view)) + -- ^ view alias + -> TypeExpression db (null ('PGcomposite view)) typeview = UnsafeTypeExpression . renderSQL -- | logical Boolean (true/false) -bool :: TypeExpression schemas (null 'PGbool) +bool :: TypeExpression db (null 'PGbool) bool = UnsafeTypeExpression "bool" -- | signed two-byte integer -int2, smallint :: TypeExpression schemas (null 'PGint2) +int2, smallint :: TypeExpression db (null 'PGint2) int2 = UnsafeTypeExpression "int2" smallint = UnsafeTypeExpression "smallint" -- | signed four-byte integer -int4, int, integer :: TypeExpression schemas (null 'PGint4) +int4, int, integer :: TypeExpression db (null 'PGint4) int4 = UnsafeTypeExpression "int4" int = UnsafeTypeExpression "int" integer = UnsafeTypeExpression "integer" -- | signed eight-byte integer -int8, bigint :: TypeExpression schemas (null 'PGint8) +int8, bigint :: TypeExpression db (null 'PGint8) int8 = UnsafeTypeExpression "int8" bigint = UnsafeTypeExpression "bigint" -- | arbitrary precision numeric type -numeric :: TypeExpression schemas (null 'PGnumeric) +numeric :: TypeExpression db (null 'PGnumeric) numeric = UnsafeTypeExpression "numeric" -- | single precision floating-point number (4 bytes) -float4, real :: TypeExpression schemas (null 'PGfloat4) +float4, real :: TypeExpression db (null 'PGfloat4) float4 = UnsafeTypeExpression "float4" real = UnsafeTypeExpression "real" -- | double precision floating-point number (8 bytes) -float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8) +float8, doublePrecision :: TypeExpression db (null 'PGfloat8) float8 = UnsafeTypeExpression "float8" doublePrecision = UnsafeTypeExpression "double precision" -- | currency amount money :: TypeExpression schema (null 'PGmoney) money = UnsafeTypeExpression "money" -- | variable-length character string -text :: TypeExpression schemas (null 'PGtext) +text :: TypeExpression db (null 'PGtext) text = UnsafeTypeExpression "text" -- | fixed-length character string char, character - :: forall n schemas null. (KnownNat n, 1 <= n) - => TypeExpression schemas (null ('PGchar n)) + :: forall n db null. (KnownNat n, 1 <= n) + => TypeExpression db (null ('PGchar n)) char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")" character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")" -- | variable-length character string varchar, characterVarying - :: forall n schemas null. (KnownNat n, 1 <= n) - => TypeExpression schemas (null ('PGvarchar n)) + :: forall n db null. (KnownNat n, 1 <= n) + => TypeExpression db (null ('PGvarchar n)) varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")" characterVarying = UnsafeTypeExpression $ "character varying(" <> renderNat @n <> ")" -- | binary data ("byte array") -bytea :: TypeExpression schemas (null 'PGbytea) +bytea :: TypeExpression db (null 'PGbytea) bytea = UnsafeTypeExpression "bytea" -- | date and time (no time zone) -timestamp :: TypeExpression schemas (null 'PGtimestamp) +timestamp :: TypeExpression db (null 'PGtimestamp) timestamp = UnsafeTypeExpression "timestamp" -- | date and time, including time zone -timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz) +timestampWithTimeZone, timestamptz :: TypeExpression db (null 'PGtimestamptz) timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone" +timestamptz = UnsafeTypeExpression "timestamptz" -- | calendar date (year, month, day) -date :: TypeExpression schemas (null 'PGdate) +date :: TypeExpression db (null 'PGdate) date = UnsafeTypeExpression "date" -- | time of day (no time zone) -time :: TypeExpression schemas (null 'PGtime) +time :: TypeExpression db (null 'PGtime) time = UnsafeTypeExpression "time" -- | time of day, including time zone -timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz) +timeWithTimeZone, timetz :: TypeExpression db (null 'PGtimetz) timeWithTimeZone = UnsafeTypeExpression "time with time zone" +timetz = UnsafeTypeExpression "timetz" -- | time span -interval :: TypeExpression schemas (null 'PGinterval) +interval :: TypeExpression db (null 'PGinterval) interval = UnsafeTypeExpression "interval" -- | universally unique identifier -uuid :: TypeExpression schemas (null 'PGuuid) +uuid :: TypeExpression db (null 'PGuuid) uuid = UnsafeTypeExpression "uuid" -- | IPv4 or IPv6 host address -inet :: TypeExpression schemas (null 'PGinet) +inet :: TypeExpression db (null 'PGinet) inet = UnsafeTypeExpression "inet" -- | textual JSON data -json :: TypeExpression schemas (null 'PGjson) +json :: TypeExpression db (null 'PGjson) json = UnsafeTypeExpression "json" -- | binary JSON data, decomposed -jsonb :: TypeExpression schemas (null 'PGjsonb) +jsonb :: TypeExpression db (null 'PGjsonb) jsonb = UnsafeTypeExpression "jsonb" -- | variable length array vararray - :: TypeExpression schemas pg - -> TypeExpression schemas (null ('PGvararray pg)) + :: TypeExpression db pg + -> TypeExpression db (null ('PGvararray pg)) vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]" -- | fixed length array -- -- >>> renderSQL (fixarray @'[2] json) -- "json[2]" fixarray - :: forall dims schemas null pg. SOP.All KnownNat dims - => TypeExpression schemas pg - -> TypeExpression schemas (null ('PGfixarray dims pg)) + :: forall dims db null pg. SOP.All KnownNat dims + => TypeExpression db pg + -> TypeExpression db (null ('PGfixarray dims pg)) fixarray ty = UnsafeTypeExpression $ renderSQL ty <> renderDims @dims where @@ -262,46 +329,207 @@ . ByteString.intercalate "][" . SOP.hcollapse $ SOP.hcmap (SOP.Proxy @KnownNat) - (K . fromString . show . natVal) + (SOP.K . fromString . show . natVal) (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns) -- | text search query -tsvector :: TypeExpression schemas (null 'PGtsvector) +tsvector :: TypeExpression db (null 'PGtsvector) tsvector = UnsafeTypeExpression "tsvector" -- | text search document -tsquery :: TypeExpression schemas (null 'PGtsquery) +tsquery :: TypeExpression db (null 'PGtsquery) tsquery = UnsafeTypeExpression "tsquery" +-- | Object identifiers (OIDs) are used internally by PostgreSQL +-- as primary keys for various system tables. +oid :: TypeExpression db (null 'PGoid) +oid = UnsafeTypeExpression "oid" +-- | Range of integer +int4range :: TypeExpression db (null ('PGrange 'PGint4)) +int4range = UnsafeTypeExpression "int4range" +-- | Range of bigint +int8range :: TypeExpression db (null ('PGrange 'PGint8)) +int8range = UnsafeTypeExpression "int8range" +-- | Range of numeric +numrange :: TypeExpression db (null ('PGrange 'PGnumeric)) +numrange = UnsafeTypeExpression "numrange" +-- | Range of timestamp without time zone +tsrange :: TypeExpression db (null ('PGrange 'PGtimestamp)) +tsrange = UnsafeTypeExpression "tsrange" +-- | Range of timestamp with time zone +tstzrange :: TypeExpression db (null ('PGrange 'PGtimestamptz)) +tstzrange = UnsafeTypeExpression "tstzrange" +-- | Range of date +daterange :: TypeExpression db (null ('PGrange 'PGdate)) +daterange = UnsafeTypeExpression "daterange" +-- | Anonymous composite record +record :: TypeExpression db (null ('PGcomposite record)) +record = UnsafeTypeExpression "record" -- | `pgtype` is a demoted version of a `PGType` -class PGTyped schemas (ty :: NullityType) where - pgtype :: TypeExpression schemas ty -instance PGTyped schemas (null 'PGbool) where pgtype = bool -instance PGTyped schemas (null 'PGint2) where pgtype = int2 -instance PGTyped schemas (null 'PGint4) where pgtype = int4 -instance PGTyped schemas (null 'PGint8) where pgtype = int8 -instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric -instance PGTyped schemas (null 'PGfloat4) where pgtype = float4 -instance PGTyped schemas (null 'PGfloat8) where pgtype = float8 -instance PGTyped schemas (null 'PGmoney) where pgtype = money -instance PGTyped schemas (null 'PGtext) where pgtype = text +class PGTyped db (ty :: PGType) where pgtype :: TypeExpression db (null ty) +instance PGTyped db 'PGbool where pgtype = bool +instance PGTyped db 'PGint2 where pgtype = int2 +instance PGTyped db 'PGint4 where pgtype = int4 +instance PGTyped db 'PGint8 where pgtype = int8 +instance PGTyped db 'PGnumeric where pgtype = numeric +instance PGTyped db 'PGfloat4 where pgtype = float4 +instance PGTyped db 'PGfloat8 where pgtype = float8 +instance PGTyped db 'PGmoney where pgtype = money +instance PGTyped db 'PGtext where pgtype = text instance (KnownNat n, 1 <= n) - => PGTyped schemas (null ('PGchar n)) where pgtype = char @n + => PGTyped db ('PGchar n) where pgtype = char @n instance (KnownNat n, 1 <= n) - => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n -instance PGTyped schemas (null 'PGbytea) where pgtype = bytea -instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp -instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone -instance PGTyped schemas (null 'PGdate) where pgtype = date -instance PGTyped schemas (null 'PGtime) where pgtype = time -instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone -instance PGTyped schemas (null 'PGinterval) where pgtype = interval -instance PGTyped schemas (null 'PGuuid) where pgtype = uuid -instance PGTyped schemas (null 'PGjson) where pgtype = json -instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb -instance PGTyped schemas ty - => PGTyped schemas (null ('PGvararray ty)) where - pgtype = vararray (pgtype @schemas @ty) -instance (SOP.All KnownNat dims, PGTyped schemas ty) - => PGTyped schemas (null ('PGfixarray dims ty)) where - pgtype = fixarray @dims (pgtype @schemas @ty) -instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector -instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery + => PGTyped db ('PGvarchar n) where pgtype = varchar @n +instance PGTyped db 'PGbytea where pgtype = bytea +instance PGTyped db 'PGtimestamp where pgtype = timestamp +instance PGTyped db 'PGtimestamptz where pgtype = timestampWithTimeZone +instance PGTyped db 'PGdate where pgtype = date +instance PGTyped db 'PGtime where pgtype = time +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 + pgtype = vararray (pgtype @db @pg) +instance (SOP.All KnownNat dims, PGTyped db pg) + => PGTyped db ('PGfixarray dims (null pg)) where + pgtype = fixarray @dims (pgtype @db @pg) +instance PGTyped db 'PGtsvector where pgtype = tsvector +instance PGTyped db 'PGtsquery where pgtype = tsquery +instance PGTyped db 'PGoid where pgtype = oid +instance PGTyped db ('PGrange 'PGint4) where pgtype = int4range +instance PGTyped db ('PGrange 'PGint8) where pgtype = int8range +instance PGTyped db ('PGrange 'PGnumeric) where pgtype = numrange +instance PGTyped db ('PGrange 'PGtimestamp) where pgtype = tsrange +instance PGTyped db ('PGrange 'PGtimestamptz) where pgtype = tstzrange +instance PGTyped db ('PGrange 'PGdate) where pgtype = daterange +instance + ( relss ~ DbRelations db + , Has sch relss rels + , Has rel rels row + , FindQualified "no relation found with row:" relss row ~ '(sch,rel) + ) => PGTyped db ('PGcomposite row) where + pgtype = typerow (QualifiedAlias @sch @rel) +instance + ( enums ~ DbEnums db + , FindQualified "no enum found with labels:" enums labels ~ '(sch,td) + , Has sch db schema + , Has td schema ('Typedef ('PGenum labels)) + ) => PGTyped db ('PGenum labels) where + pgtype = typedef (QualifiedAlias @sch @td) + +-- | Specify `TypeExpression` from a Haskell type. +-- +-- >>> printSQL $ pgtypeFrom @String +-- text +-- +-- >>> printSQL $ pgtypeFrom @Double +-- float8 +pgtypeFrom + :: forall hask db null. PGTyped db (PG hask) + => TypeExpression db (null (PG hask)) +pgtypeFrom = pgtype @db @(PG hask) + +-- | Lift `PGTyped` to a field +class FieldTyped db ty where fieldtype :: Aliased (TypeExpression db) ty +instance (KnownSymbol alias, NullTyped db ty) + => FieldTyped db (alias ::: ty) where + fieldtype = nulltype `As` Alias + +-- | `ColumnTypeExpression`s are used in +-- `Squeal.PostgreSQL.Definition.createTable` commands. +newtype ColumnTypeExpression (db :: SchemasType) (ty :: ColumnType) + = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (ColumnTypeExpression db ty) where + renderSQL = renderColumnTypeExpression + +-- | used in `Squeal.PostgreSQL.Definition.createTable` +-- commands as a column constraint to note that +-- @NULL@ may be present in a column +nullable + :: TypeExpression db (null ty) + -- ^ type + -> ColumnTypeExpression db ('NoDef :=> 'Null ty) +nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL" + +-- | used in `Squeal.PostgreSQL.Definition.createTable` +-- commands as a column constraint to ensure +-- @NULL@ is not present in a column +notNullable + :: TypeExpression db (null ty) + -- ^ type + -> ColumnTypeExpression db ('NoDef :=> 'NotNull ty) +notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL" + +-- | used in `Squeal.PostgreSQL.Definition.createTable` +-- commands as a column constraint to give a default +default_ + :: Expression 'Ungrouped '[] '[] db '[] '[] ty + -- ^ default value + -> ColumnTypeExpression db ('NoDef :=> ty) + -- ^ column type + -> ColumnTypeExpression db ('Def :=> ty) +default_ x ty = UnsafeColumnTypeExpression $ + renderSQL ty <+> "DEFAULT" <+> renderExpression x + +-- | not a true type, but merely a notational convenience for creating +-- unique identifier columns with type `PGint2` +serial2, smallserial + :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint2) +serial2 = UnsafeColumnTypeExpression "serial2" +smallserial = UnsafeColumnTypeExpression "smallserial" +-- | not a true type, but merely a notational convenience for creating +-- unique identifier columns with type `PGint4` +serial4, serial + :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint4) +serial4 = UnsafeColumnTypeExpression "serial4" +serial = UnsafeColumnTypeExpression "serial" +-- | not a true type, but merely a notational convenience for creating +-- unique identifier columns with type `PGint8` +serial8, bigserial + :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint8) +serial8 = UnsafeColumnTypeExpression "serial8" +bigserial = UnsafeColumnTypeExpression "bigserial" + +-- | Like @PGTyped@ but also accounts for null. +class NullTyped db (ty :: NullType) where + nulltype :: TypeExpression db ty + +instance PGTyped db ty => NullTyped db (null ty) where + nulltype = pgtype @db @ty + +-- | Specify null `TypeExpression` from a Haskell type. +-- +-- >>> printSQL $ nulltypeFrom @(Maybe String) +-- text +-- +-- >>> printSQL $ nulltypeFrom @Double +-- float8 +nulltypeFrom + :: forall hask db. NullTyped db (NullPG hask) + => TypeExpression db (NullPG hask) +nulltypeFrom = nulltype @db @(NullPG hask) + +-- | Like @PGTyped@ but also accounts for null. +class ColumnTyped db (column :: ColumnType) where + columntype :: ColumnTypeExpression db column +instance NullTyped db ('Null ty) + => ColumnTyped db ('NoDef :=> 'Null ty) where + columntype = nullable (nulltype @db @('Null ty)) +instance NullTyped db ('NotNull ty) + => ColumnTyped db ('NoDef :=> 'NotNull ty) where + columntype = notNullable (nulltype @db @('NotNull ty)) + +-- | Specify `ColumnTypeExpression` from a Haskell type. +-- +-- >>> printSQL $ columntypeFrom @(Maybe String) +-- text NULL +-- +-- >>> printSQL $ columntypeFrom @Double +-- float8 NOT NULL +columntypeFrom + :: forall hask db. (ColumnTyped db ('NoDef :=> NullPG hask)) + => ColumnTypeExpression db ('NoDef :=> NullPG hask) +columntypeFrom = columntype @db @('NoDef :=> NullPG hask) 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 @@ -1,30 +1,47 @@ {-| Module: Squeal.PostgreSQL.Expression.Window -Description: Window functions +Description: window functions, arguments and definitions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Window functions and definitions +window functions, arguments and definitions -} {-# LANGUAGE DataKinds , DeriveGeneric + , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving + , KindSignatures , LambdaCase , MultiParamTypeClasses , OverloadedStrings + , PatternSynonyms , RankNTypes - , KindSignatures + , ScopedTypeVariables + , TypeApplications + , TypeOperators + , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Window - ( -- * functions - partitionBy + ( -- * Window Definition + WindowDefinition (..) + , partitionBy + -- * Window Function + -- ** Types + , WindowFunction (..) + , WindowArg (..) + , pattern Window + , pattern Windows + , WinFun0 + , type (-#->) + , type (--#->) + -- ** Functions , rank , rowNumber , denseRank @@ -38,91 +55,79 @@ , nthValue , unsafeWindowFunction1 , unsafeWindowFunctionN - -- * types - , WindowFunction (..) - , WindowDefinition (..) - , WinFun0 - , WinFun1 - , WinFunN ) where import Control.DeepSeq -import Data.ByteString +import Data.ByteString (ByteString) import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP -import Squeal.PostgreSQL.Alias +import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Aggregate +import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.List +import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -instance Aggregate - (Expression outer commons grp schemas params from) - (NP (Expression outer commons grp schemas params from)) - (WindowFunction outer commons grp schemas params from) where - countStar = UnsafeWindowFunction "count(*)" - count = unsafeWindowFunction1 "count" - sum_ = unsafeWindowFunction1 "sum" - arrayAgg = unsafeWindowFunction1 "array_agg" - jsonAgg = unsafeWindowFunction1 "json_agg" - jsonbAgg = unsafeWindowFunction1 "jsonb_agg" - bitAnd = unsafeWindowFunction1 "bit_and" - bitOr = unsafeWindowFunction1 "bit_or" - boolAnd = unsafeWindowFunction1 "bool_and" - boolOr = unsafeWindowFunction1 "bool_or" - every = unsafeWindowFunction1 "every" - max_ = unsafeWindowFunction1 "max" - min_ = unsafeWindowFunction1 "min" - avg = unsafeWindowFunction1 "avg" - corr = unsafeWindowFunctionN "corr" - covarPop = unsafeWindowFunctionN "covar_pop" - covarSamp = unsafeWindowFunctionN "covar_samp" - regrAvgX = unsafeWindowFunctionN "regr_avgx" - regrAvgY = unsafeWindowFunctionN "regr_avgy" - regrCount = unsafeWindowFunctionN "regr_count" - regrIntercept = unsafeWindowFunctionN "regr_intercept" - regrR2 = unsafeWindowFunctionN "regr_r2" - regrSlope = unsafeWindowFunctionN "regr_slope" - regrSxx = unsafeWindowFunctionN "regr_sxx" - regrSxy = unsafeWindowFunctionN "regr_sxy" - regrSyy = unsafeWindowFunctionN "regr_syy" - stddev = unsafeWindowFunction1 "stddev" - stddevPop = unsafeWindowFunction1 "stddev_pop" - stddevSamp = unsafeWindowFunction1 "stddev_samp" - variance = unsafeWindowFunction1 "variance" - varPop = unsafeWindowFunction1 "var_pop" - varSamp = unsafeWindowFunction1 "var_samp" +instance Aggregate (WindowArg grp) (WindowFunction grp) where + countStar = UnsafeWindowFunction "count(*)" + count = unsafeWindowFunction1 "count" + sum_ = unsafeWindowFunction1 "sum" + arrayAgg = unsafeWindowFunction1 "array_agg" + jsonAgg = unsafeWindowFunction1 "json_agg" + jsonbAgg = unsafeWindowFunction1 "jsonb_agg" + bitAnd = unsafeWindowFunction1 "bit_and" + bitOr = unsafeWindowFunction1 "bit_or" + boolAnd = unsafeWindowFunction1 "bool_and" + boolOr = unsafeWindowFunction1 "bool_or" + every = unsafeWindowFunction1 "every" + max_ = unsafeWindowFunction1 "max" + min_ = unsafeWindowFunction1 "min" + avg = unsafeWindowFunction1 "avg" + corr = unsafeWindowFunctionN "corr" + covarPop = unsafeWindowFunctionN "covar_pop" + covarSamp = unsafeWindowFunctionN "covar_samp" + regrAvgX = unsafeWindowFunctionN "regr_avgx" + regrAvgY = unsafeWindowFunctionN "regr_avgy" + regrCount = unsafeWindowFunctionN "regr_count" + regrIntercept = unsafeWindowFunctionN "regr_intercept" + regrR2 = unsafeWindowFunctionN "regr_r2" + regrSlope = unsafeWindowFunctionN "regr_slope" + regrSxx = unsafeWindowFunctionN "regr_sxx" + regrSxy = unsafeWindowFunctionN "regr_sxy" + regrSyy = unsafeWindowFunctionN "regr_syy" + stddev = unsafeWindowFunction1 "stddev" + stddevPop = unsafeWindowFunction1 "stddev_pop" + stddevSamp = unsafeWindowFunction1 "stddev_samp" + variance = unsafeWindowFunction1 "variance" + varPop = unsafeWindowFunction1 "var_pop" + varSamp = unsafeWindowFunction1 "var_samp" -- | A `WindowDefinition` is a set of table rows that are somehow related -- to the current row -data WindowDefinition outer commons grp schemas params from where +data WindowDefinition grp lat with db params from where WindowDefinition :: SOP.SListI bys - => NP (Expression outer commons grp schemas params from) bys + => NP (Expression grp lat with db params from) bys -- ^ `partitionBy` clause - -> [SortExpression outer commons grp schemas params from] + -> [SortExpression grp lat with db params from] -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause - -> WindowDefinition outer commons grp schemas params from + -> WindowDefinition grp lat with db params from -instance OrderBy WindowDefinition where +instance OrderBy (WindowDefinition grp) grp where orderBy sortsR (WindowDefinition parts sortsL) = WindowDefinition parts (sortsL ++ sortsR) -instance RenderSQL (WindowDefinition outer commons schemas from grp params) where +instance RenderSQL (WindowDefinition grp lat with db params from) where renderSQL (WindowDefinition part ord) = - renderPartitionByClause part <> renderOrderByClause ord + renderPartitionByClause part <> renderSQL ord where renderPartitionByClause = \case Nil -> "" parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts - renderOrderByClause = \case - [] -> "" - srts -> " ORDER" <+> "BY" - <+> commaSeparated (renderSQL <$> srts) {- | The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups, @@ -132,8 +137,8 @@ -} partitionBy :: SOP.SListI bys - => NP (Expression outer commons grp schemas params from) bys -- ^ partitions - -> WindowDefinition outer commons grp schemas params from + => NP (Expression grp lat with db params from) bys -- ^ partitions + -> WindowDefinition grp lat with db params from partitionBy bys = WindowDefinition bys [] {- | @@ -147,57 +152,116 @@ just the current row of the query result. -} newtype WindowFunction - (outer :: FromType) - (commons :: FromType) (grp :: Grouping) - (schemas :: SchemasType) - (params :: [NullityType]) + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) (from :: FromType) - (ty :: NullityType) + (ty :: NullType) = UnsafeWindowFunction { renderWindowFunction :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) -instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where +{- | +`WindowArg`s are used for the input of `WindowFunction`s. +-} +data WindowArg + (grp :: Grouping) + (args :: [NullType]) + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (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 (HasUnique tab (Join from lat) row, Has col row ty) + => IsLabel col (WindowArg 'Ungrouped '[ty] lat with db params from) where + fromLabel = Window (fromLabel @col) +instance (Has tab (Join from lat) row, Has col row ty) + => IsQualified tab col (WindowArg 'Ungrouped '[ty] lat with db params from) where + tab ! col = Window (tab ! col) +instance (HasUnique tab (Join from lat) row, Has col row ty, GroupedBy tab col bys) + => IsLabel col (WindowArg ('Grouped bys) '[ty] lat with db params from) where + fromLabel = Window (fromLabel @col) +instance (Has tab (Join from lat) row, Has col row ty, GroupedBy tab col bys) + => IsQualified tab col (WindowArg ('Grouped bys) '[ty] lat with db params from) where + tab ! col = Window (tab ! col) + +instance SOP.SListI args + => RenderSQL (WindowArg grp args lat with db params from) where + renderSQL (WindowArg args filters) = + parenthesized (renderCommaSeparated renderSQL args) + & renderFilters filters + where + renderFilter wh = "FILTER" <+> parenthesized ("WHERE" <+> wh) + renderFilters = \case + [] -> id + wh:whs -> (<+> renderFilter (renderSQL (foldr (.&&) wh whs))) + +instance FilterWhere (WindowArg grp) grp where + filterWhere wh (WindowArg args filters) = WindowArg args (wh : filters) + +-- | `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 [] + +instance RenderSQL (WindowFunction grp lat with db params from ty) where renderSQL = renderWindowFunction {- | A @RankNType@ for window functions with no arguments. -} type WinFun0 x - = forall outer commons grp schemas params from - . WindowFunction outer commons grp schemas params from x + = forall grp lat with db params from + . WindowFunction grp lat with db params from x -- ^ cannot reference aliases {- | A @RankNType@ for window functions with 1 argument. -} -type WinFun1 x y - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x +type (-#->) x y + = forall grp lat with db params from + . WindowArg grp '[x] lat with db params from -- ^ input - -> WindowFunction outer commons grp schemas params from y + -> WindowFunction grp lat with db params from y -- ^ output {- | A @RankNType@ for window functions with a fixed-length list of heterogeneous arguments. Use the `*:` operator to end your argument lists. -} -type WinFunN xs y - = forall outer commons grp schemas params from - . NP (Expression outer commons grp schemas params from) xs +type (--#->) xs y + = forall grp lat with db params from + . WindowArg grp xs lat with db params from -- ^ inputs - -> WindowFunction outer commons grp schemas params from y + -> WindowFunction grp lat with db params from y -- ^ output -- | escape hatch for defining window functions -unsafeWindowFunction1 :: ByteString -> WinFun1 x y +unsafeWindowFunction1 :: ByteString -> x -#-> y unsafeWindowFunction1 fun x - = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x) + = UnsafeWindowFunction $ fun <> renderSQL x -- | escape hatch for defining multi-argument window functions -unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y -unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <> - parenthesized (renderCommaSeparated renderSQL xs) +unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> xs --#-> y +unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <> renderSQL xs {- | rank of the current row with gaps; same as `rowNumber` of its first peer @@ -243,10 +307,10 @@ {- | integer ranging from 1 to the argument value, dividing the partition as equally as possible ->>> printSQL $ ntile 5 -ntile(5) +>>> printSQL $ ntile (Window 5) +ntile((5 :: int4)) -} -ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4) +ntile :: 'NotNull 'PGint4 -#-> 'NotNull 'PGint4 ntile = unsafeWindowFunction1 "ntile" {- | returns value evaluated at the row that is offset rows before the current @@ -254,7 +318,7 @@ (which must be of the same type as value). Both offset and default are evaluated with respect to the current row. -} -lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty +lag :: '[ty, 'NotNull 'PGint4, ty] --#-> ty lag = unsafeWindowFunctionN "lag" {- | returns value evaluated at the row that is offset rows after the current @@ -262,23 +326,23 @@ (which must be of the same type as value). Both offset and default are evaluated with respect to the current row. -} -lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty +lead :: '[ty, 'NotNull 'PGint4, ty] --#-> ty lead = unsafeWindowFunctionN "lead" {- | returns value evaluated at the row that is the first row of the window frame -} -firstValue :: WinFun1 ty ty +firstValue :: ty -#-> ty firstValue = unsafeWindowFunction1 "first_value" {- | returns value evaluated at the row that is the last row of the window frame -} -lastValue :: WinFun1 ty ty +lastValue :: ty -#-> ty lastValue = unsafeWindowFunction1 "last_value" {- | returns value evaluated at the row that is the nth row of the window frame (counting from 1); null if no such row -} -nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty) +nthValue :: '[null ty, 'NotNull 'PGint4] --#-> 'Null ty nthValue = unsafeWindowFunctionN "nth_value" diff --git a/src/Squeal/PostgreSQL/List.hs b/src/Squeal/PostgreSQL/List.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/List.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.List -Description: List related types and functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Haskell singly-linked lists are very powerful. This module -provides functionality for type-level lists, heterogeneous -lists and type aligned lists. --} - -{-# LANGUAGE - DataKinds - , FlexibleContexts - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PolyKinds - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.List - ( SOP.NP (..) - , (*:) - , Join - , disjoin - , Additional (..) - , AlignedList (..) - , single - , extractList - , mapAligned - , Elem - , In - , Length - ) where - -import Control.Category -import Data.Function ((&)) -import Data.Kind -import Data.Type.Bool -import GHC.TypeLits - -import Generics.SOP as SOP - -import Squeal.PostgreSQL.Render - --- | `Join` is simply promoted `++` and is used in @JOIN@s in --- `Squeal.PostgreSQL.Query.FromClause`s. -type family Join xs ys where - Join '[] ys = ys - Join (x ': xs) ys = x ': Join xs ys - --- | `disjoin` is a utility function for splitting an `NP` list into pieces. -disjoin - :: forall xs ys expr. SListI xs - => NP expr (Join xs ys) - -> (NP expr xs, NP expr ys) -disjoin = case sList @xs of - SNil -> \ys -> (Nil, ys) - SCons -> \(x :* xsys) -> - case disjoin xsys of (xs,ys) -> (x :* xs, ys) - --- | The `Additional` class is for appending --- type-level list parameterized constructors such as `NP`, --- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`. -class Additional expr where - also :: expr ys -> expr xs -> expr (Join xs ys) -instance Additional (NP expr) where - also ys = \case - Nil -> ys - x :* xs -> x :* (xs & also ys) - --- | An `AlignedList` is a type-aligned list or free category. -data AlignedList p x0 x1 where - Done :: AlignedList p x x - (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2 -infixr 7 :>> -instance Category (AlignedList p) where - id = Done - (.) list = \case - Done -> list - step :>> steps -> step :>> (steps >>> list) -instance (forall t0 t1. RenderSQL (p t0 t1)) - => RenderSQL (AlignedList p x0 x1) where - renderSQL = \case - Done -> "" - step :>> Done -> renderSQL step - step :>> steps -> renderSQL step <> ", " <> renderSQL steps - --- | `extractList` turns an `AlignedList` into a standard list. -extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b] -extractList f = \case - Done -> [] - step :>> steps -> (f step):extractList f steps - --- | `mapAligned` applies a function to each element of an `AlignedList`. -mapAligned - :: (forall z0 z1. p z0 z1 -> q z0 z1) - -> AlignedList p x0 x1 - -> AlignedList q x0 x1 -mapAligned f = \case - Done -> Done - x :>> xs -> f x :>> mapAligned f xs - --- | A `single` step. -single :: p x0 x1 -> AlignedList p x0 x1 -single step = step :>> Done - --- | A useful operator for ending an `NP` list of length at least 2 without `Nil`. -(*:) :: f x -> f y -> NP f '[x,y] -x *: y = x :* y :* Nil -infixl 9 *: - --- | @Elem@ is a promoted `Data.List.elem`. -type family Elem x xs where - Elem x '[] = 'False - Elem x (x ': xs) = 'True - Elem x (_ ': xs) = Elem x xs - --- | @In x xs@ is a constraint that proves that @x@ is in @xs@. -type family In x xs :: Constraint where - In x xs = If (Elem x xs) (() :: Constraint) - (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs)) - -{- | Calculate the `Length` of a type level list - ->>> :kind! Length '[Char,String,Bool,Double] -Length '[Char,String,Bool,Double] :: Nat -= 4 --} -type family Length (xs :: [k]) :: Nat where - Length (x : xs) = 1 + Length xs - Length '[] = 0 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 @@ -1,15 +1,16 @@ {-| Module: Squeal.PostgreSQL.Manipulation -Description: Squeal data manipulation language -Copyright: (c) Eitan Chatav, 2017 +Description: data manipulation language +Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Squeal data manipulation language. +data manipulation language -} {-# LANGUAGE DeriveGeneric + , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs @@ -23,52 +24,40 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , UndecidableInstances #-} module Squeal.PostgreSQL.Manipulation ( -- * Manipulation - Manipulation_ - , Manipulation (..) + Manipulation (..) + , Manipulation_ , queryStatement - -- * Insert - , insertInto - , insertInto_ - -- * Update - , update - , update_ - -- * Delete - , deleteFrom - , deleteFrom_ - -- * Clauses - , Optional (..) - , QueryClause (..) - , pattern Values_ , ReturningClause (..) , pattern Returning_ - , ConflictClause (..) - , ConflictTarget (..) - , ConflictAction (..) , UsingClause (..) ) where import Control.DeepSeq import Data.ByteString hiding (foldr) import Data.Kind (Type) +import Data.Quiver.Functor import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Alias +import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.PG +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Query.From +import Squeal.PostgreSQL.Query.Select +import Squeal.PostgreSQL.Query.With +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -77,88 +66,79 @@ {- | 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 -* @commons :: FromType@ - scope for all `common` table expressions, -* @schemas :: SchemasType@ - scope for all `table`s and `view`s, -* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, -* @row :: RowType@ - return type of the `Query`. --} -newtype Manipulation - (commons :: FromType) - (schemas :: SchemasType) - (params :: [NullityType]) - (columns :: RowType) - = UnsafeManipulation { renderManipulation :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (Manipulation commons schemas params columns) where - renderSQL = renderManipulation -instance With Manipulation where - with Done manip = manip - with ctes manip = UnsafeManipulation $ - "WITH" <+> renderSQL ctes <+> renderSQL manip - -{- | -The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`, -against which the query is type-checked, an input @parameters@ Haskell `Type`, -and an ouput row Haskell `Type`. +* @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 `Manipulation`. -A top-level `Manipulation_` can be run -using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@ -using `Squeal.PostgreSQL.PQ.manipulate`. +Let's see some examples of `Manipulation`s. -Generally, @parameters@ 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. +simple insert: ->>> :set -XDeriveAnyClass -XDerivingStrategies +>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ -data Row a b = Row { col1 :: a, col2 :: b } - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +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) -simple insert: +out-of-line parameterized insert: ->>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4] +>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let - manipulation :: Manipulation_ (Public Schema) () () - manipulation = - insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) -in printSQL manipulation + manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[] + manp = + insertInto_ #tab $ Values_ + (Default `as` #col1 :* Set (param @1) `as` #col2) +in printSQL manp :} -INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4)) -parameterized insert: +in-line parameterized insert: ->>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] +>>> 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) (Int32, Int32) () - manipulation = - insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2)) -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 (($1 :: int4), ($2 :: 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, 3) RETURNING "col1" AS "fromOnly" +INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "col1" upsert: @@ -167,46 +147,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', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "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 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: @@ -219,15 +199,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: @@ -235,151 +215,106 @@ >>> 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" -} -type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where - Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row) - --- | Convert a `Query` into a `Manipulation`. -queryStatement - :: Query '[] commons schemas params columns - -> Manipulation commons schemas params columns -queryStatement q = UnsafeManipulation $ renderSQL q - -{----------------------------------------- -INSERT statements ------------------------------------------} +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 {- | -When a table is created, it contains no data. The first thing to do -before a database can be of much use is to insert data. Data is -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. --} -insertInto - :: ( Has sch schemas schema - , Has tab schema ('Table table) - , columns ~ TableToColumns table - , row0 ~ TableToRow table - , SOP.SListI columns - , SOP.SListI row1 ) - => QualifiedAlias sch tab - -> QueryClause commons schemas params columns - -> ConflictClause tab commons schemas params table - -> ReturningClause commons schemas params '[tab ::: row0] row1 - -> Manipulation commons schemas params row1 -insertInto tab qry conflict ret = UnsafeManipulation $ - "INSERT" <+> "INTO" <+> renderSQL tab - <+> renderSQL qry - <> renderSQL conflict - <> renderSQL ret +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`. --- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`. -insertInto_ - :: ( Has sch schemas schema - , Has tab schema ('Table table) - , columns ~ TableToColumns table - , row ~ TableToRow table - , SOP.SListI columns ) - => QualifiedAlias sch tab - -> QueryClause commons schemas params columns - -> Manipulation commons schemas params '[] -insertInto_ tab qry = - insertInto tab qry OnConflictDoRaise (Returning_ Nil) +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 `QueryClause` describes what to `insertInto` a table. -data QueryClause commons schemas params columns where - -- | `Values` describes `NP` lists of `Aliased` `Optional` `Expression`s - -- whose `ColumnsType` must match the tables'. - Values - :: SOP.SListI columns - => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns - -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns] - -> QueryClause commons schemas params columns - -- | `Select` describes a subquery that permits use of `Optional` `Expression`s. - Select - :: SOP.SListI columns - => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns - -> TableExpression '[] commons grp schemas params from - -> QueryClause commons schemas params columns - -- | `Subquery` describes a subquery whose `RowType` must match the tables'. - Subquery - :: ColumnsToRow columns ~ row - => Query '[] commons schemas params row - -> QueryClause commons schemas params columns +A `Manipulation_` can be run +using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@ +using `Squeal.PostgreSQL.Session.manipulate`. -instance RenderSQL (QueryClause commons schemas params columns) where - renderSQL = \case - Values row0 rows -> - parenthesized (renderCommaSeparated renderSQLPart row0) - <+> "VALUES" - <+> commaSeparated - ( parenthesized - . renderCommaSeparated renderValuePart <$> row0 : rows ) - Select row0 tab -> - parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0) - <+> "SELECT" - <+> renderCommaSeparatedMaybe renderValuePartMaybe row0 - <+> renderSQL tab - Subquery qry -> renderQuery qry - where - renderSQLPartMaybe, renderValuePartMaybe - :: Aliased (Optional (Expression '[] commons grp schemas params from)) column - -> Maybe ByteString - renderSQLPartMaybe = \case - Default `As` _ -> Nothing - Set _ `As` name -> Just $ renderSQL name - renderValuePartMaybe = \case - Default `As` _ -> Nothing - Set value `As` _ -> Just $ renderExpression value - renderSQLPart, renderValuePart - :: Aliased (Optional (Expression '[] commons grp schemas params from)) column - -> ByteString - renderSQLPart (_ `As` name) = renderSQL name - renderValuePart (value `As` _) = renderSQL value +`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. --- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s --- whose `ColumnsType` must match the tables'. -pattern Values_ - :: SOP.SListI columns - => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns - -> QueryClause commons schemas params columns -pattern Values_ vals = Values vals [] +>>> :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) +:} --- | `Optional` is either `Default` or a value, parameterized by an appropriate --- `ColumnConstraint`. -data Optional expr ty where - -- | Use the `Default` value for a column. - Default :: Optional expr ('Def :=> ty) - -- | `Set` a value for a column. - Set :: expr ty -> Optional expr (def :=> ty) +>>> :{ +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 +:} -instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where - renderSQL = \case - Default -> "DEFAULT" - Set expr -> renderSQL expr +>>> :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) --- | A `ReturningClause` computes and return value(s) based +-- | Convert a `Query` into a `Manipulation`. +queryStatement + :: Query '[] with db params columns + -- ^ `Query` to embed as a `Manipulation` + -> Manipulation with db params columns +queryStatement q = UnsafeManipulation $ renderSQL q + +-- | 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 -- is allowed. Only rows that were successfully inserted or updated or -- deleted will be returned. For example, if a row was locked --- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied, +-- 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 commons schemas params from row = - Returning (Selection '[] commons 'Ungrouped schemas params from row) +newtype ReturningClause with db params from row = + Returning (Selection 'Ungrouped '[] with db params from row) -instance RenderSQL (ReturningClause commons schemas params from row) where +instance RenderSQL (ReturningClause with db params from row) where renderSQL = \case Returning (List Nil) -> "" Returning selection -> " RETURNING" <+> renderSQL selection @@ -387,183 +322,23 @@ -- | `Returning` a `List` pattern Returning_ :: SOP.SListI row - => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row - -> ReturningClause commons schemas params from row + => NP (Aliased (Expression 'Ungrouped '[] with db params from)) row + -- ^ row of values + -> ReturningClause with db params from row pattern Returning_ list = Returning (List list) --- | A `ConflictClause` specifies an action to perform upon a constraint --- violation. `OnConflictDoRaise` will raise an error. --- `OnConflict` `DoNothing` simply avoids inserting a row. --- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row --- proposed for insertion. -data ConflictClause tab commons schemas params table where - OnConflictDoRaise :: ConflictClause tab commons schemas params table - OnConflict - :: ConflictTarget constraints - -> ConflictAction tab commons schemas params columns - -> ConflictClause tab commons schemas params (constraints :=> columns) - --- | Render a `ConflictClause`. -instance SOP.SListI (TableToColumns table) - => RenderSQL (ConflictClause tab commons schemas params table) where - renderSQL = \case - OnConflictDoRaise -> "" - OnConflict target action -> " ON CONFLICT" - <+> renderSQL target <+> renderSQL action - -{- | -`ConflictAction` specifies an alternative `OnConflict` action. -It can be either `DoNothing`, or a `DoUpdate` clause specifying -the exact details of the `update` action to be performed in case of a conflict. -The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the -existing row using the table's name (or an alias), and to rows proposed -for insertion using the special @#excluded@ table. --} -data ConflictAction tab commons schemas params columns where - -- | `OnConflict` `DoNothing` simply avoids inserting a row as its alternative action. - DoNothing :: ConflictAction tab commons schemas params columns - -- | `OnConflict` `DoUpdate` updates the existing row that conflicts - -- with the row proposed for insertion as its alternative action. - DoUpdate - :: ( row ~ ColumnsToRow columns - , SOP.SListI columns - , columns ~ (col0 ': cols) - , SOP.All (HasIn columns) subcolumns - , AllUnique subcolumns ) - => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns - -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]] - -- ^ WHERE `Condition`s - -> ConflictAction tab commons schemas params columns - -instance RenderSQL (ConflictAction tab commons schemas params columns) where - renderSQL = \case - DoNothing -> "DO NOTHING" - DoUpdate updates whs' - -> "DO UPDATE SET" - <+> renderCommaSeparated renderUpdate updates - <> case whs' of - [] -> "" - wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs) - -renderUpdate - :: (forall x. RenderSQL (expr x)) - => Aliased (Optional expr) ty - -> ByteString -renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr - --- | A `ConflictTarget` specifies the constraint violation that triggers a --- `ConflictAction`. -data ConflictTarget constraints where - OnConstraint - :: Has con constraints constraint - => Alias con - -> ConflictTarget constraints - --- | Render a `ConflictTarget` -instance RenderSQL (ConflictTarget constraints) where - renderSQL (OnConstraint con) = - "ON" <+> "CONSTRAINT" <+> renderSQL con - -{----------------------------------------- -UPDATE statements ------------------------------------------} - --- | An `update` command changes the values of the specified columns --- in all rows that satisfy the condition. -update - :: ( SOP.SListI columns - , SOP.SListI row1 - , db ~ (commons :=> schemas) - , Has sch schemas schema - , Has tab schema ('Table table) - , row0 ~ TableToRow table - , columns ~ TableToColumns table - , SOP.All (HasIn columns) subcolumns - , AllUnique subcolumns ) - => QualifiedAlias sch tab -- ^ table to update - -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns - -- ^ modified values to replace old values - -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0] - -- ^ condition under which to perform update on a row - -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return - -> Manipulation commons schemas params row1 -update tab columns wh returning = UnsafeManipulation $ - "UPDATE" - <+> renderSQL tab - <+> "SET" - <+> renderCommaSeparated renderUpdate columns - <+> "WHERE" <+> renderSQL wh - <> renderSQL returning - --- | Update a row returning `Nil`. -update_ - :: ( SOP.SListI columns - , db ~ (commons :=> schemas) - , Has sch schemas schema - , Has tab schema ('Table table) - , row ~ TableToRow table - , columns ~ TableToColumns table - , SOP.All (HasIn columns) subcolumns - , AllUnique subcolumns ) - => QualifiedAlias sch tab -- ^ table to update - -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns - -- ^ modified values to replace old values - -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row] - -- ^ condition under which to perform update on a row - -> Manipulation commons schemas params '[] -update_ tab columns wh = update tab columns wh (Returning_ Nil) - -{----------------------------------------- -DELETE statements ------------------------------------------} - --- | Specify additional tables. -data UsingClause commons schemas params from where - -- | No `UsingClause` - NoUsing :: UsingClause commons schemas params '[] - -- | 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. +-- | 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 '[] commons schemas params from - -> UsingClause commons schemas params from - --- | Delete rows from a table. -deleteFrom - :: ( SOP.SListI row1 - , db ~ (commons :=> schemas) - , Has sch schemas schema - , Has tab schema ('Table table) - , row0 ~ TableToRow table - , columns ~ TableToColumns table ) - => QualifiedAlias sch tab -- ^ table to delete from - -> UsingClause commons schemas params from - -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from) - -- ^ condition under which to delete a row - -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return - -> Manipulation commons schemas params row1 -deleteFrom tab using wh returning = UnsafeManipulation $ - "DELETE FROM" - <+> renderSQL tab - <> case using of - NoUsing -> "" - Using tables -> " USING" <+> renderSQL tables - <+> "WHERE" <+> renderSQL wh - <> renderSQL returning - --- | Delete rows returning `Nil`. -deleteFrom_ - :: ( db ~ (commons :=> schemas) - , Has sch schemas schema - , Has tab schema ('Table table) - , row ~ TableToRow table - , columns ~ TableToColumns table ) - => QualifiedAlias sch tab -- ^ table to delete from - -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row] - -- ^ condition under which to delete a row - -> Manipulation commons schemas params '[] -deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil) + :: 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,118 @@ +{-| +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 + , DataKinds + , PolyKinds + , 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 new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Manipulation/Delete.hs @@ -0,0 +1,106 @@ +{-| +Module: Squeal.PostgreSQL.Delete +Description: delete statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +delete statements +-} + +{-# LANGUAGE + DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PatternSynonyms + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Manipulation.Delete + ( -- * Delete + deleteFrom + , deleteFrom_ + ) where + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{----------------------------------------- +DELETE statements +-----------------------------------------} + +{- | 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 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 ': from) row + -- ^ results to return + -> Manipulation with db params row +deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $ + "DELETE FROM" + <+> renderSQL tab0 <+> "AS" <+> renderSQL tab + <> case using of + NoUsing -> "" + Using tables -> " USING" <+> renderSQL tables + <+> "WHERE" <+> renderSQL wh + <> renderSQL returning + +{- | 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 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 '[] +deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil) diff --git a/src/Squeal/PostgreSQL/Manipulation/Insert.hs b/src/Squeal/PostgreSQL/Manipulation/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Manipulation/Insert.hs @@ -0,0 +1,289 @@ +{-| +Module: Squeal.PostgreSQL.Manipulation.Insert +Description: insert statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +insert statements +-} + +{-# LANGUAGE + DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PatternSynonyms + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Manipulation.Insert + ( -- * Insert + insertInto + , insertInto_ + -- * Clauses + , QueryClause (..) + , pattern Values_ + , inlineValues + , inlineValues_ + , ConflictClause (..) + , ConflictTarget (..) + , ConflictAction (..) + ) where + +import Data.ByteString hiding (foldr) + +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Record as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Default +import Squeal.PostgreSQL.Expression.Inline +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Query.Table +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{----------------------------------------- +INSERT statements +-----------------------------------------} + +{- | +When a table is created, it contains no data. The first thing to do +before a database can be of much use is to insert data. Data is +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 tab0 schema ('Table table) + , SOP.SListI (TableToColumns table) + , SOP.SListI row ) + => Aliased (QualifiedAlias sch) (tab ::: tab0) + -- ^ table + -> QueryClause with db params (TableToColumns table) + -- ^ what to insert + -> ConflictClause tab with db params table + -- ^ what to do in case of conflict + -> ReturningClause with db params '[tab ::: TableToRow table] row + -- ^ what to return + -> Manipulation with db params row +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`. + +>>> 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 tab0 schema ('Table table) + , SOP.SListI (TableToColumns table) ) + => Aliased (QualifiedAlias sch) (tab ::: tab0) + -- ^ table + -> QueryClause with db params (TableToColumns table) + -- ^ what to insert + -> Manipulation with db params '[] +insertInto_ tab qry = + insertInto tab qry OnConflictDoRaise (Returning_ Nil) + +-- | A `QueryClause` describes what to `insertInto` a table. +data QueryClause with db params columns where + Values + :: SOP.SListI columns + => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns + -- ^ row of values + -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns] + -- ^ additional rows of values + -> QueryClause with db params columns + Select + :: SOP.SListI columns + => NP (Aliased (Optional (Expression grp '[] with db params from))) columns + -- ^ row of values + -> TableExpression grp '[] with db params from + -- ^ from a table expression + -> QueryClause with db params columns + Subquery + :: ColumnsToRow columns ~ row + => Query '[] with db params row + -- ^ subquery to insert + -> QueryClause with db params columns + +instance RenderSQL (QueryClause with db params columns) where + renderSQL = \case + Values row0 rows -> + parenthesized (renderCommaSeparated renderSQLPart row0) + <+> "VALUES" + <+> commaSeparated + ( parenthesized + . renderCommaSeparated renderValuePart <$> row0 : rows ) + Select row0 tab -> + parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0) + <+> "SELECT" + <+> renderCommaSeparatedMaybe renderValuePartMaybe row0 + <+> renderSQL tab + Subquery qry -> renderQuery qry + where + renderSQLPartMaybe, renderValuePartMaybe + :: Aliased (Optional (Expression grp '[] with db params from)) column + -> Maybe ByteString + renderSQLPartMaybe = \case + Default `As` _ -> Nothing + Set _ `As` name -> Just $ renderSQL name + renderValuePartMaybe = \case + Default `As` _ -> Nothing + Set value `As` _ -> Just $ renderExpression value + renderSQLPart, renderValuePart + :: Aliased (Optional (Expression grp '[] with db params from)) column + -> ByteString + renderSQLPart (_ `As` name) = renderSQL name + renderValuePart (value `As` _) = renderSQL value + +-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s +-- whose `ColumnsType` must match the tables'. +pattern Values_ + :: SOP.SListI columns + => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns + -- ^ row of values + -> QueryClause with db params columns +pattern Values_ vals = Values vals [] + +-- | `inlineValues_` a Haskell record in `insertInto`. +inlineValues_ + :: ( SOP.IsRecord hask xs + , SOP.AllZip InlineColumn xs columns ) + => hask -- ^ record + -> QueryClause with db params columns +inlineValues_ = Values_ . inlineColumns + +-- | `inlineValues` Haskell records in `insertInto`. +inlineValues + :: ( SOP.IsRecord hask xs + , SOP.AllZip InlineColumn xs columns ) + => hask -- ^ record + -> [hask] -- ^ more + -> QueryClause with db params columns +inlineValues hask hasks = Values (inlineColumns hask) (inlineColumns <$> hasks) + +-- | A `ConflictClause` specifies an action to perform upon a constraint +-- violation. `OnConflictDoRaise` will raise an error. +-- `OnConflict` `DoNothing` simply avoids inserting a row. +-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row +-- proposed for insertion. +data ConflictClause tab with db params table where + OnConflictDoRaise :: ConflictClause tab with db params table + OnConflict + :: ConflictTarget table + -- ^ conflict target + -> ConflictAction tab with db params table + -- ^ conflict action + -> ConflictClause tab with db params table + +-- | Render a `ConflictClause`. +instance SOP.SListI (TableToColumns table) + => RenderSQL (ConflictClause tab with db params table) where + renderSQL = \case + OnConflictDoRaise -> "" + OnConflict target action -> " ON CONFLICT" + <+> renderSQL target <+> renderSQL action + +{- | +`ConflictAction` specifies an alternative `OnConflict` action. +It can be either `DoNothing`, or a `DoUpdate` clause specifying +the exact details of the update action to be performed in case of a conflict. +The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the +existing row using the table's name, and to rows proposed +for insertion using the special @#excluded@ row. +`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action. +`OnConflict` `DoUpdate` updates the existing row that conflicts +with the row proposed for insertion as its alternative action. +-} +data ConflictAction tab with db params table where + DoNothing :: ConflictAction tab with db params table + DoUpdate + :: ( row ~ TableToRow table + , from ~ '[tab ::: row, "excluded" ::: row] + , Updatable table updates ) + => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) updates + -> [Condition 'Ungrouped '[] with db params from] + -- ^ WHERE `Condition`s + -> ConflictAction tab with db params table + +instance RenderSQL (ConflictAction tab with db params table) where + renderSQL = \case + DoNothing -> "DO NOTHING" + DoUpdate updates whs' + -> "DO UPDATE SET" + <+> renderCommaSeparated renderUpdate updates + <> case whs' of + [] -> "" + wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs) + +renderUpdate + :: (forall x. RenderSQL (expr x)) + => Aliased (Optional expr) ty + -> ByteString +renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr + +-- | A `ConflictTarget` specifies the constraint violation that triggers a +-- `ConflictAction`. +data ConflictTarget table where + OnConstraint + :: Has con constraints constraint + => Alias con + -> ConflictTarget (constraints :=> columns) + +-- | Render a `ConflictTarget` +instance RenderSQL (ConflictTarget constraints) where + renderSQL (OnConstraint con) = + "ON" <+> "CONSTRAINT" <+> renderSQL con diff --git a/src/Squeal/PostgreSQL/Manipulation/Update.hs b/src/Squeal/PostgreSQL/Manipulation/Update.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Manipulation/Update.hs @@ -0,0 +1,135 @@ +{-| +Module: Squeal.PostgreSQL.Update +Description: update statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +update statements +-} + +{-# LANGUAGE + DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PatternSynonyms + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Manipulation.Update + ( -- * Update + update + , update_ + ) where + +import Data.ByteString hiding (foldr) +import GHC.TypeLits + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Default +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +renderUpdate + :: (forall x. RenderSQL (expr x)) + => Aliased (Optional expr) ty + -> ByteString +renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr + +{----------------------------------------- +UPDATE statements +-----------------------------------------} + +{- | 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 tab0 schema ('Table table) + , Updatable table updates + , SOP.SListI row ) + => 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 (tab0 `As` tab) columns using wh returning = UnsafeManipulation $ + "UPDATE" + <+> 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`. + +>>> 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 tab0 schema ('Table table) + , KnownSymbol tab + , Updatable 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 NoUsing wh (Returning_ Nil) diff --git a/src/Squeal/PostgreSQL/Migration.hs b/src/Squeal/PostgreSQL/Migration.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Migration.hs +++ /dev/null @@ -1,446 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Migration -Description: Squeal migrations -Copyright: (c) Eitan Chatav, 2017 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module defines a `Migration` type to safely -change the schema of your database over time. Let's see an example! - -First turn on some extensions. - ->>> :set -XDataKinds -XOverloadedLabels ->>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators - -Next, let's define our `TableType`s. - ->>> :{ -type UsersTable = - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] -:} - ->>> :{ -type EmailsTable = - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ] -:} - -Now we can define some `Migration`s to make our tables. - ->>> :{ -let - makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]] - makeUsers = Migration - { name = "make users table" - , up = createTable #users - ( serial `as` #id :* - notNullable text `as` #name ) - ( primaryKey #id `as` #pk_users ) - , down = dropTable #users - } -:} - ->>> :{ -let - makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]] - '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]] - makeEmails = Migration - { name = "make emails table" - , up = createTable #emails - ( serial `as` #id :* - notNullable int `as` #user_id :* - nullable text `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) - , down = dropTable #emails - } -:} - -Now that we have a couple migrations we can chain them together into an `AlignedList`. - ->>> let migrations = makeUsers :>> makeEmails :>> Done - -Now run the migrations. - ->>> import Control.Monad.IO.Class ->>> :{ -withConnection "host=localhost port=5432 dbname=exampledb" $ - manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;") - -- suppress notices - & pqThen (liftIO (putStrLn "Migrate")) - & pqThen (migrateUp migrations) - & pqThen (liftIO (putStrLn "Rollback")) - & pqThen (migrateDown migrations) -:} -Migrate -Rollback - -We can also create a simple executable using `defaultMain`. - ->>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations - ->>> withArgs [] main -Invalid command: "". Use: -migrate to run all available migrations -rollback to rollback all available migrations -status to display migrations run and migrations left to run - ->>> withArgs ["status"] main -Migrations already run: - None -Migrations left to run: - - make users table - - make emails table - ->>> withArgs ["migrate"] main -Migrations already run: - - make users table - - make emails table -Migrations left to run: - None - ->>> withArgs ["rollback"] main -Migrations already run: - None -Migrations left to run: - - make users table - - make emails table - -In addition to enabling `Migration`s using pure SQL `Definition`s for -the `up` and `down` instructions, you can also perform impure `IO` actions -by using a `Migration`s over the `Terminally` `PQ` `IO` category. --} - -{-# LANGUAGE - DataKinds - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , OverloadedLabels - , OverloadedStrings - , PolyKinds - , QuantifiedConstraints - , RankNTypes - , TypeApplications - , TypeOperators -#-} - -module Squeal.PostgreSQL.Migration - ( -- * Migration - Migration (..) - , Migratory (..) - , Terminally (..) - , terminally - , pureMigration - , MigrationsTable - , defaultMain - ) where - -import Control.Category -import Control.Monad -import Data.ByteString (ByteString) -import Data.Foldable (traverse_) -import Data.Function ((&)) -import Data.List ((\\)) -import Data.Text (Text) -import Data.Time (UTCTime) -import Prelude hiding ((.), id) -import System.Environment -import UnliftIO (MonadIO (..)) - -import qualified Data.Text.IO as Text (putStrLn) -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.Binary -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Expression.Comparison -import Squeal.PostgreSQL.Expression.Parameter -import Squeal.PostgreSQL.Expression.Time -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.PQ -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Schema -import Squeal.PostgreSQL.Transaction - --- | A `Migration` is a named "isomorphism" over a given category. --- It should contain an inverse pair of `up` and `down` --- instructions and a unique `name`. -data Migration p schemas0 schemas1 = Migration - { name :: Text -- ^ The `name` of a `Migration`. - -- Each `name` in a `Migration` should be unique. - , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`. - , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`. - } deriving (GHC.Generic) - -{- | -A `Migratory` @p@ is a `Category` for which one can execute or rewind -an `AlignedList` of `Migration`s over @p@. This includes the category of pure -SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions. --} -class Category p => Migratory p where - - {- | - Run an `AlignedList` of `Migration`s. - Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist. - In one transaction, for each each `Migration` query to see if the `Migration` has been executed; - if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`. - -} - migrateUp - :: AlignedList (Migration p) schemas0 schemas1 - -> PQ schemas0 schemas1 IO () - - {- | - Rewind an `AlignedList` of `Migration`s. - Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist. - In one transaction, for each each `Migration` query to see if the `Migration` has been executed; - if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`. - -} - migrateDown - :: AlignedList (Migration p) schemas0 schemas1 - -> PQ schemas1 schemas0 IO () - -instance Migratory Definition where - migrateUp = migrateUp . mapAligned pureMigration - migrateDown = migrateDown . mapAligned pureMigration - -{- | `Terminally` turns an indexed monad transformer and the monad it transforms -into a category by restricting the return type to @()@ and permuting the type variables. -This is similar to how applying a monad to @()@ yields a monoid. -Since a `Terminally` action has a trivial return value, the only reason -to run one is for the side effects, in particular database and other IO effects. --} -newtype Terminally trans monad x0 x1 = Terminally - { runTerminally :: trans x0 x1 monad () } - deriving GHC.Generic - -instance - ( IndexedMonadTransPQ trans - , Monad monad - , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) ) - => Category (Terminally trans monad) where - id = Terminally (return ()) - Terminally g . Terminally f = Terminally $ pqThen g f - --- | `terminally` ignores the output of a computation, returning @()@ and --- wrapping it up into a `Terminally`. You can lift an action in the base monad --- by using @terminally . lift@. -terminally - :: Functor (trans x0 x1 monad) - => trans x0 x1 monad ignore - -> Terminally trans monad x0 x1 -terminally = Terminally . void - --- | A `pureMigration` turns a `Migration` involving only pure SQL --- `Definition`s into a `Migration` that may be combined with arbitrary `IO`. -pureMigration - :: Migration Definition schemas0 schemas1 - -> Migration (Terminally PQ IO) schemas0 schemas1 -pureMigration migration = Migration - { name = name migration - , up = terminally . define $ up migration - , down = terminally . define $ down migration - } - -instance Migratory (Terminally PQ IO) where - - migrateUp migration = unsafePQ . transactionally_ $ do - define createMigrations - upMigrations migration - - where - - upMigrations - :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1 - -> PQ MigrationsSchemas MigrationsSchemas IO () - upMigrations = \case - Done -> return () - step :>> steps -> upMigration step >> upMigrations steps - - upMigration - :: Migration (Terminally PQ IO) schemas0 schemas1 - -> PQ MigrationsSchemas MigrationsSchemas IO () - upMigration step = do - executed <- queryExecuted step - unless (executed == 1) $ do - unsafePQ . runTerminally $ up step - manipulateParams_ insertMigration (Only (name step)) - - queryExecuted - :: Migration (Terminally PQ IO) schemas0 schemas1 - -> PQ MigrationsSchemas MigrationsSchemas IO Row - queryExecuted step = do - result <- runQueryParams selectMigration (Only (name step)) - ntuples result - - migrateDown migrations = unsafePQ . transactionally_ $ do - define createMigrations - downMigrations migrations - - where - - downMigrations - :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1 - -> PQ MigrationsSchemas MigrationsSchemas IO () - downMigrations = \case - Done -> return () - step :>> steps -> downMigrations steps >> downMigration step - - downMigration - :: Migration (Terminally PQ IO) schemas0 schemas1 - -> PQ MigrationsSchemas MigrationsSchemas IO () - downMigration step = do - executed <- queryExecuted step - unless (executed == 0) $ do - unsafePQ . runTerminally $ down step - manipulateParams_ deleteMigration (Only (name step)) - - queryExecuted - :: Migration (Terminally PQ IO) schemas0 schemas1 - -> PQ MigrationsSchemas MigrationsSchemas IO Row - queryExecuted step = do - result <- runQueryParams selectMigration (Only (name step)) - ntuples result - -unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x -unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK - --- | The `TableType` for a Squeal migration. -type MigrationsTable = - '[ "migrations_unique_name" ::: 'Unique '["name"]] :=> - '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext - , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz - ] - -data MigrationRow = - MigrationRow { migrationName :: Text - , migrationTime :: UTCTime } - deriving (GHC.Generic, Show) - -instance SOP.Generic MigrationRow -instance SOP.HasDatatypeInfo MigrationRow - -type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable] -type MigrationsSchemas = Public MigrationsSchema - --- | Creates a `MigrationsTable` if it does not already exist. -createMigrations :: Definition MigrationsSchemas MigrationsSchemas -createMigrations = - createTableIfNotExists #schema_migrations - ( (text & notNullable) `as` #name :* - (timestampWithTimeZone & notNullable & default_ currentTimestamp) - `as` #executed_at ) - ( unique #name `as` #migrations_unique_name ) - --- | Inserts a `Migration` into the `MigrationsTable`, returning --- the time at which it was inserted. -insertMigration :: Manipulation_ MigrationsSchemas (Only Text) () -insertMigration = insertInto_ #schema_migrations - (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at)) - --- | Deletes a `Migration` from the `MigrationsTable`, returning --- the time at which it was inserted. -deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) () -deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1) - --- | Selects a `Migration` from the `MigrationsTable`, returning --- the time at which it was inserted. -selectMigration - :: Query_ MigrationsSchemas (Only Text) (Only UTCTime) -selectMigration = select_ (#executed_at `as` #fromOnly) - $ from (table (#schema_migrations)) - & where_ (#name .== param @1) - -selectMigrations :: Query_ MigrationsSchemas () MigrationRow -selectMigrations = select_ - (#name `as` #migrationName :* #executed_at `as` #migrationTime) - (from (table #schema_migrations)) - -data MigrateCommand - = MigrateStatus - | MigrateUp - | MigrateDown deriving (GHC.Generic, Show) - -{- | `defaultMain` creates a simple executable -from a connection string and a list of `Migration`s. -} -defaultMain - :: Migratory p - => ByteString - -- ^ connection string - -> AlignedList (Migration p) db0 db1 - -- ^ migrations - -> IO () -defaultMain connectTo migrations = do - command <- readCommandFromArgs - maybe (pure ()) performCommand command - - where - - performCommand :: MigrateCommand -> IO () - performCommand = \case - MigrateStatus -> withConnection connectTo $ - suppressNotices >> migrateStatus - MigrateUp -> withConnection connectTo $ - suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus - MigrateDown -> withConnection connectTo $ - suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus - - migrateStatus :: PQ schema schema IO () - migrateStatus = unsafePQ $ do - runNames <- getRunMigrationNames - let names = extractList name migrations - unrunNames = names \\ runNames - liftIO $ displayRunned runNames >> displayUnrunned unrunNames - - suppressNotices :: PQ schema schema IO () - suppressNotices = manipulate_ $ - UnsafeManipulation "SET client_min_messages TO WARNING;" - - readCommandFromArgs :: IO (Maybe MigrateCommand) - readCommandFromArgs = getArgs >>= \case - ["migrate"] -> pure . Just $ MigrateUp - ["rollback"] -> pure . Just $ MigrateDown - ["status"] -> pure . Just $ MigrateStatus - args -> displayUsage args >> pure Nothing - - displayUsage :: [String] -> IO () - displayUsage args = do - putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:" - putStrLn "migrate to run all available migrations" - putStrLn "rollback to rollback all available migrations" - putStrLn "status to display migrations run and migrations left to run" - - getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text] - getRunMigrationNames = - fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows) - - displayListOfNames :: [Text] -> IO () - displayListOfNames [] = Text.putStrLn " None" - displayListOfNames xs = - let singleName n = Text.putStrLn $ " - " <> n - in traverse_ singleName xs - - displayUnrunned :: [Text] -> IO () - displayUnrunned unrunned = - Text.putStrLn "Migrations left to run:" - >> displayListOfNames unrunned - - displayRunned :: [Text] -> IO () - displayRunned runned = - Text.putStrLn "Migrations already run:" - >> displayListOfNames runned diff --git a/src/Squeal/PostgreSQL/PG.hs b/src/Squeal/PostgreSQL/PG.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/PG.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.PG -Description: Embedding of Haskell types into Postgres's type system -Copyright: (c) Eitan Chatav, 2010 -Maintainer: eitan@morphism.tech -Stability: experimental - -`Squeal.PostgreSQL.PG` provides type families for turning Haskell -`Type`s into corresponding Postgres types. --} -{-# LANGUAGE - AllowAmbiguousTypes - , DeriveFoldable - , DeriveFunctor - , DeriveGeneric - , DeriveTraversable - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , OverloadedStrings - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.PG - ( -- * PG embeddings - PG - , NullPG - , TuplePG - , RowPG - -- * Storage newtypes - , Money (..) - , Json (..) - , Jsonb (..) - , Composite (..) - , Enumerated (..) - , VarArray (..) - , FixArray (..) - -- * Type families - , LabelsPG - , DimPG - , FixPG - , TupleOf - , TupleCodeOf - , RowOf - , ConstructorsOf - , ConstructorNameOf - , ConstructorNamesOf - ) where - -import Data.Aeson (Value) -import Data.Kind (Type) -import Data.Int (Int16, Int32, Int64) -import Data.Scientific (Scientific) -import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime) -import Data.Vector (Vector) -import Data.Word (Word16, Word32, Word64) -import Data.UUID.Types (UUID) -import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) - -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text as Strict (Text) -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Record as SOP -import qualified Generics.SOP.Type.Metadata as Type - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.Schema - --- $setup --- >>> import Squeal.PostgreSQL --- >>> import Data.Text (Text) - -{- | The `PG` type family embeds a subset of Haskell types -as Postgres types. As an open type family, `PG` is extensible. - ->>> :kind! PG LocalTime -PG LocalTime :: PGType -= 'PGtimestamp - ->>> newtype MyDouble = My Double ->>> :set -XTypeFamilies ->>> type instance PG MyDouble = 'PGfloat8 --} -type family PG (hask :: Type) :: PGType --- | `PGbool` -type instance PG Bool = 'PGbool --- | `PGint2` -type instance PG Int16 = 'PGint2 --- | `PGint4` -type instance PG Int32 = 'PGint4 --- | `PGint8` -type instance PG Int64 = 'PGint8 --- | `PGint2` -type instance PG Word16 = 'PGint2 --- | `PGint4` -type instance PG Word32 = 'PGint4 --- | `PGint8` -type instance PG Word64 = 'PGint8 --- | `PGnumeric` -type instance PG Scientific = 'PGnumeric --- | `PGfloat4` -type instance PG Float = 'PGfloat4 --- | `PGfloat8` -type instance PG Double = 'PGfloat8 --- | `PGchar` @1@ -type instance PG Char = 'PGchar 1 --- | `PGtext` -type instance PG Strict.Text = 'PGtext --- | `PGtext` -type instance PG Lazy.Text = 'PGtext --- | `PGtext` -type instance PG String = 'PGtext --- | `PGbytea` -type instance PG Strict.ByteString = 'PGbytea --- | `PGbytea` -type instance PG Lazy.ByteString = 'PGbytea --- | `PGtimestamp` -type instance PG LocalTime = 'PGtimestamp --- | `PGtimestamptz` -type instance PG UTCTime = 'PGtimestamptz --- | `PGdate` -type instance PG Day = 'PGdate --- | `PGtime` -type instance PG TimeOfDay = 'PGtime --- | `PGtimetz` -type instance PG (TimeOfDay, TimeZone) = 'PGtimetz --- | `PGinterval` -type instance PG DiffTime = 'PGinterval --- | `PGuuid` -type instance PG UUID = 'PGuuid --- | `PGinet` -type instance PG (NetAddr IP) = 'PGinet --- | `PGjson` -type instance PG Value = 'PGjson - -{-| The `LabelsPG` type family calculates the constructors of a -Haskell enum type. - ->>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic ->>> instance SOP.Generic Schwarma ->>> instance SOP.HasDatatypeInfo Schwarma ->>> :kind! LabelsPG Schwarma -LabelsPG Schwarma :: [Type.ConstructorName] -= '["Beef", "Lamb", "Chicken"] --} -type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where - LabelsPG hask = - ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask)) - -{- | -`RowPG` turns a Haskell `Type` into a `RowType`. - -`RowPG` may be applied to normal Haskell record types provided they -have `SOP.Generic` and `SOP.HasDatatypeInfo` instances; - ->>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic ->>> instance SOP.Generic Person ->>> instance SOP.HasDatatypeInfo Person ->>> :kind! RowPG Person -RowPG Person :: [(Symbol, NullityType)] -= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4] --} -type family RowPG (hask :: Type) :: RowType where - RowPG hask = RowOf (SOP.RecordCodeOf hask) - --- | `RowOf` applies `NullPG` to the fields of a list. -type family RowOf (record :: [(Symbol, Type)]) :: RowType where - RowOf '[] = '[] - RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record - -{- | `NullPG` turns a Haskell type into a `NullityType`. - ->>> :kind! NullPG Double -NullPG Double :: NullityType -= 'NotNull 'PGfloat8 ->>> :kind! NullPG (Maybe Double) -NullPG (Maybe Double) :: NullityType -= 'Null 'PGfloat8 --} -type family NullPG (hask :: Type) :: NullityType where - NullPG (Maybe hask) = 'Null (PG hask) - NullPG hask = 'NotNull (PG hask) - -{- | `TuplePG` turns a Haskell tuple type (including record types) into -the corresponding list of `NullityType`s. - ->>> :kind! TuplePG (Double, Maybe Char) -TuplePG (Double, Maybe Char) :: [NullityType] -= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)] --} -type family TuplePG (hask :: Type) :: [NullityType] where - TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask)) - --- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s. -type family TupleOf (tuple :: [Type]) :: [NullityType] where - TupleOf '[] = '[] - TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple - --- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type` --- and if it's a simple product returns it, otherwise giving a `TypeError`. -type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where - TupleCodeOf hask '[tuple] = tuple - TupleCodeOf hask '[] = - TypeError - ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type." - ':$$: 'Text "It is a void type with no constructors." - ) - TupleCodeOf hask (_ ': _ ': _) = - TypeError - ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type." - ':$$: 'Text "It is a sum type with more than one constructor." - ) - --- | Calculates constructors of a datatype. -type family ConstructorsOf (datatype :: Type.DatatypeInfo) - :: [Type.ConstructorInfo] where - ConstructorsOf ('Type.ADT _module _datatype constructors) = - constructors - ConstructorsOf ('Type.Newtype _module _datatype constructor) = - '[constructor] - --- | Calculates the name of a nullary constructor, otherwise --- generates a type error. -type family ConstructorNameOf (constructor :: Type.ConstructorInfo) - :: Type.ConstructorName where - ConstructorNameOf ('Type.Constructor name) = name - ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError - ('Text "ConstructorNameOf error: non-nullary constructor " - ':<>: 'Text name) - ConstructorNameOf ('Type.Record name _fields) = TypeError - ('Text "ConstructorNameOf error: non-nullary constructor " - ':<>: 'Text name) - --- | Calculate the names of nullary constructors. -type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo]) - :: [Type.ConstructorName] where - ConstructorNamesOf '[] = '[] - ConstructorNamesOf (constructor ': constructors) = - ConstructorNameOf constructor ': ConstructorNamesOf constructors - --- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths. -type family DimPG (hask :: Type) :: [Nat] where - DimPG (x,x) = 2 ': DimPG x - DimPG (x,x,x) = 3 ': DimPG x - DimPG (x,x,x,x) = 4 ': DimPG x - DimPG (x,x,x,x,x) = 5 ': DimPG x - DimPG (x,x,x,x,x,x) = 6 ': DimPG x - DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x - DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x - DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x - DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x - DimPG x = '[] - --- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples. -type family FixPG (hask :: Type) :: NullityType where - FixPG (x,x) = FixPG x - FixPG (x,x,x) = FixPG x - FixPG (x,x,x,x) = FixPG x - FixPG (x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x - FixPG x = NullPG x - -{- | 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 }@. - ->>> import Control.Monad (void) ->>> import Control.Monad.IO.Class (liftIO) ->>> import Squeal.PostgreSQL ->>> :{ -let - roundTrip :: Query_ (Public '[]) (Only Money) (Only Money) - roundTrip = values_ $ parameter @1 money `as` #fromOnly -:} - ->>> let input = Only (Money 20020) - ->>> :{ -withConnection "host=localhost port=5432 dbname=exampledb" $ do - result <- runQueryParams roundTrip input - Just output <- firstRow result - liftIO . print $ input == output -:} -True --} -newtype Money = Money { cents :: Int64 } - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGmoney` -type instance PG Money = 'PGmoney - -{- | The `Json` newtype is an indication that the Haskell -type it's applied to should be stored as a `PGjson`. --} -newtype Json hask = Json {getJson :: hask} - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGjson` -type instance PG (Json hask) = 'PGjson - -{- | The `Jsonb` newtype is an indication that the Haskell -type it's applied to should be stored as a `PGjsonb`. --} -newtype Jsonb hask = Jsonb {getJsonb :: hask} - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGjsonb` -type instance PG (Jsonb hask) = 'PGjsonb - -{- | The `Composite` newtype is an indication that the Haskell -type it's applied to should be stored as a `PGcomposite`. --} -newtype Composite record = Composite {getComposite :: record} - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGcomposite` @(@`RowPG` @hask)@ -type instance PG (Composite hask) = 'PGcomposite (RowPG hask) - -{- | The `Enumerated` newtype is an indication that the Haskell -type it's applied to should be stored as a `PGenum`. --} -newtype Enumerated enum = Enumerated {getEnumerated :: enum} - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGenum` @(@`LabelsPG` @hask)@ -type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask) - -{- | The `VarArray` newtype is an indication that the Haskell -type it's applied to should be stored as a `PGvararray`. - ->>> :kind! PG (VarArray (Vector Double)) -PG (VarArray (Vector Double)) :: PGType -= 'PGvararray ('NotNull 'PGfloat8) --} -newtype VarArray arr = VarArray {getVarArray :: arr} - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGvararray` @(@`NullPG` @hask)@ -type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask) -type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask) - -{- | The `FixArray` newtype is an indication that the Haskell -type it's applied to should be stored as a `PGfixarray`. - ->>> :kind! PG (FixArray ((Double, Double), (Double, Double))) -PG (FixArray ((Double, Double), (Double, Double))) :: PGType -= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8) --} -newtype FixArray arr = FixArray {getFixArray :: arr} - deriving (Eq, Ord, Show, Read, GHC.Generic) --- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@ -type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask) diff --git a/src/Squeal/PostgreSQL/PQ.hs b/src/Squeal/PostgreSQL/PQ.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/PQ.hs +++ /dev/null @@ -1,688 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.PQ -Description: PQ monad -Copyright: (c) Eitan Chatav, 2017 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module is where Squeal commands actually get executed by -`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing -a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`, -and a `PQ` type with instances for them. - -Using Squeal in your application will come down to defining -the @schemas@ of your database and including @PQ schemas schemas@ in your -application's monad transformer stack, giving it an instance of `MonadPQ`. - -This module also provides functions for retrieving rows from the `LibPQ.Result` -of executing Squeal commands. --} - -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE - DefaultSignatures - , FunctionalDependencies - , FlexibleContexts - , FlexibleInstances - , InstanceSigs - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.PQ - ( -- * Connection - LibPQ.Connection - , connectdb - , finish - , withConnection - , lowerConnection - -- * PQ - , PQ (PQ, unPQ) - , runPQ - , execPQ - , evalPQ - , IndexedMonadTransPQ (..) - , MonadPQ (..) - -- * Results - , LibPQ.Result - , LibPQ.Row - , ntuples - , getRow - , getRows - , nextRow - , firstRow - , liftResult - , LibPQ.ExecStatus (..) - , resultStatus - , resultErrorMessage - , resultErrorCode - -- * Exceptions - , SquealException (..) - , PQState (..) - , okResult - , catchSqueal - , handleSqueal - , trySqueal - ) where - -import Control.Exception (Exception, throw) -import Control.Monad.Except -import Control.Monad.Morph -import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try) -import Data.ByteString (ByteString) -import Data.Foldable -import Data.Function ((&)) -import Data.Kind -import Data.Text (pack, Text) -import Data.Traversable -import Generics.SOP -import PostgreSQL.Binary.Encoding (encodingBytes) - -import qualified Control.Monad.Fail as Fail -import qualified Database.PostgreSQL.LibPQ as LibPQ - -import Squeal.PostgreSQL.Binary -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Schema - --- For `MonadPQ` transformer instances -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Cont - -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.State.Strict as Strict -import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import qualified Control.Monad.Trans.Writer.Strict as Strict -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Strict as Strict - --- $setup --- >>> import Squeal.PostgreSQL - -{- | Makes a new connection to the database server. - -This function opens a new database connection using the parameters taken -from the string conninfo. - -The passed string can be empty to use all default parameters, or it can -contain one or more parameter settings separated by whitespace. -Each parameter setting is in the form keyword = value. Spaces around the equal -sign are optional. To write an empty value or a value containing spaces, -surround it with single quotes, e.g., keyword = 'a value'. Single quotes and -backslashes within the value must be escaped with a backslash, i.e., ' and \. - -To specify the schema you wish to connect with, use type application. - ->>> :set -XDataKinds ->>> :set -XPolyKinds ->>> :set -XTypeOperators ->>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]] ->>> :set -XTypeApplications ->>> :set -XOverloadedStrings ->>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb" - -Note that, for now, squeal doesn't offer any protection from connecting -with the wrong schema! --} -connectdb - :: forall schemas io - . MonadIO io - => ByteString -- ^ conninfo - -> io (K LibPQ.Connection schemas) -connectdb = fmap K . liftIO . LibPQ.connectdb - --- | Closes the connection to the server. -finish :: MonadIO io => K LibPQ.Connection schemas -> io () -finish = liftIO . LibPQ.finish . unK - --- | Do `connectdb` and `finish` before and after a computation. -withConnection - :: forall schemas0 schemas1 io x - . MonadUnliftIO io - => ByteString - -> PQ schemas0 schemas1 io x - -> io x -withConnection connString action = do - K x <- bracket (connectdb connString) finish (unPQ action) - return x - --- | Safely `lowerConnection` to a smaller schema. -lowerConnection - :: K LibPQ.Connection (schema ': schemas) - -> K LibPQ.Connection schemas -lowerConnection (K conn) = K conn - --- | We keep track of the schema via an Atkey indexed state monad transformer, --- `PQ`. -newtype PQ - (schemas0 :: SchemasType) - (schemas1 :: SchemasType) - (m :: Type -> Type) - (x :: Type) = - PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) } - -instance Monad m => Functor (PQ schemas0 schemas1 m) where - fmap f (PQ pq) = PQ $ \ conn -> do - K x <- pq conn - return $ K (f x) - --- | Run a `PQ` and keep the result and the `LibPQ.Connection`. -runPQ - :: Functor m - => PQ schemas0 schemas1 m x - -> K LibPQ.Connection schemas0 - -> m (x, K LibPQ.Connection schemas1) -runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn - -- K x <- pq conn - -- return (x, K (unK conn)) - --- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`. -execPQ - :: Functor m - => PQ schemas0 schemas1 m x - -> K LibPQ.Connection schemas0 - -> m (K LibPQ.Connection schemas1) -execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn - --- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result. -evalPQ - :: Functor m - => PQ schemas0 schemas1 m x - -> K LibPQ.Connection schemas0 - -> m x -evalPQ (PQ pq) conn = unK <$> pq conn - --- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor` --- [enriched category](https://ncatlab.org/nlab/show/enriched+category). --- An indexed monad transformer transforms a `Monad` into an indexed monad. --- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that --- support running `Definition`s using `define`. -class IndexedMonadTransPQ pq where - - -- | indexed analog of `<*>` - pqAp - :: Monad m - => pq schemas0 schemas1 m (x -> y) - -> pq schemas1 schemas2 m x - -> pq schemas0 schemas2 m y - - -- | indexed analog of `join` - pqJoin - :: Monad m - => pq schemas0 schemas1 m (pq schemas1 schemas2 m y) - -> pq schemas0 schemas2 m y - pqJoin pq = pq & pqBind id - - -- | indexed analog of `=<<` - pqBind - :: Monad m - => (x -> pq schemas1 schemas2 m y) - -> pq schemas0 schemas1 m x - -> pq schemas0 schemas2 m y - - -- | indexed analog of flipped `>>` - pqThen - :: Monad m - => pq schemas1 schemas2 m y - -> pq schemas0 schemas1 m x - -> pq schemas0 schemas2 m y - pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) - - -- | indexed analog of `<=<` - pqAndThen - :: Monad m - => (y -> pq schemas1 schemas2 m z) - -> (x -> pq schemas0 schemas1 m y) - -> x -> pq schemas0 schemas2 m z - pqAndThen g f x = pqBind g (f x) - - -- | Run a `Definition` with `LibPQ.exec`. - -- - -- It should be functorial in effect. - -- - -- @define id = return ()@ - -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@ - define - :: MonadIO io - => Definition schemas0 schemas1 - -> pq schemas0 schemas1 io () - -instance IndexedMonadTransPQ PQ where - - pqAp (PQ f) (PQ x) = PQ $ \ conn -> do - K f' <- f conn - K x' <- x (K (unK conn)) - return $ K (f' x') - - pqBind f (PQ x) = PQ $ \ conn -> do - K x' <- x conn - unPQ (f x') (K (unK conn)) - - define (UnsafeDefinition q) = PQ $ \ (K conn) -> do - resultMaybe <- liftIO $ LibPQ.exec conn q - case resultMaybe of - Nothing -> throw $ ResultException - "define: LibPQ.exec returned no results" - Just result -> K <$> okResult_ result - -{- | `MonadPQ` is an @mtl@ style constraint, similar to -`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to - -* `manipulateParams` runs a `Manipulation` with params from a type - with a `ToParams` constraint. It calls `LibPQ.execParams` and - doesn't afraid of anything. - -* `manipulateParams_` is like `manipulateParams` for a returning-free statement. - -* `manipulate` is like `manipulateParams` for a parameter-free statement. - -* `manipulate_` is like `manipulate` for a returning-free statement. - -* `runQueryParams` is like `manipulateParams` for query statements. - -* `runQuery` is like `runQueryParams` for a parameter-free statement. - -* `traversePrepared` has the same type signature as a composition of - `traverse` and `manipulateParams` but provides an optimization by - preparing the statement with `LibPQ.prepare` and then traversing a - `Traversable` container with `LibPQ.execPrepared`. The temporary prepared - statement is then deallocated. - -* `forPrepared` is a flipped `traversePrepared` - -* `traversePrepared_` is like `traversePrepared` but works on `Foldable` - containers for a returning-free statement. - -* `forPrepared_` is a flipped `traversePrepared_`. - -* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection - into your monad. - -To define an instance, you can minimally define only `manipulateParams`, -`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get -a default instance. - --} -class Monad pq => MonadPQ schemas pq | pq -> schemas where - manipulateParams - :: ToParams x params - => Manipulation '[] schemas params ys - -- ^ `insertInto`, `update` or `deleteFrom` - -> x -> pq (K LibPQ.Result ys) - default manipulateParams - :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) - => ToParams x params - => Manipulation '[] schemas params ys - -- ^ `insertInto`, `update` or `deleteFrom` - -> x -> pq (K LibPQ.Result ys) - manipulateParams manipulation params = lift $ - manipulateParams manipulation params - - manipulateParams_ - :: ToParams x params - => Manipulation '[] schemas params '[] - -- ^ `insertInto`, `update` or `deleteFrom` - -> x -> pq () - manipulateParams_ q x = void $ manipulateParams q x - - manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys) - manipulate statement = manipulateParams statement () - - manipulate_ :: Manipulation '[] schemas '[] '[] -> pq () - manipulate_ = void . manipulate - - runQueryParams - :: ToParams x params - => Query '[] '[] schemas params ys - -- ^ `select` and friends - -> x -> pq (K LibPQ.Result ys) - runQueryParams = manipulateParams . queryStatement - - runQuery - :: Query '[] '[] schemas '[] ys - -- ^ `select` and friends - -> pq (K LibPQ.Result ys) - runQuery q = runQueryParams q () - - traversePrepared - :: (ToParams x params, Traversable list) - => Manipulation '[] schemas params ys - -- ^ `insertInto`, `update`, or `deleteFrom`, and friends - -> list x -> pq (list (K LibPQ.Result ys)) - default traversePrepared - :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) - => (ToParams x params, Traversable list) - => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys)) - traversePrepared manipulation params = lift $ - traversePrepared manipulation params - - forPrepared - :: (ToParams x params, Traversable list) - => list x - -> Manipulation '[] schemas params ys - -- ^ `insertInto`, `update` or `deleteFrom` - -> pq (list (K LibPQ.Result ys)) - forPrepared = flip traversePrepared - - traversePrepared_ - :: (ToParams x params, Foldable list) - => Manipulation '[] schemas params '[] - -- ^ `insertInto`, `update` or `deleteFrom` - -> list x -> pq () - default traversePrepared_ - :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) - => (ToParams x params, Foldable list) - => Manipulation '[] schemas params '[] - -- ^ `insertInto`, `update` or `deleteFrom` - -> list x -> pq () - traversePrepared_ manipulation params = lift $ - traversePrepared_ manipulation params - - forPrepared_ - :: (ToParams x params, Foldable list) - => list x - -> Manipulation '[] schemas params '[] - -- ^ `insertInto`, `update` or `deleteFrom` - -> pq () - forPrepared_ = flip traversePrepared_ - - liftPQ :: (LibPQ.Connection -> IO a) -> pq a - default liftPQ - :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) - => (LibPQ.Connection -> IO a) -> pq a - liftPQ = lift . liftPQ - -instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas) - => MonadPQ schemas (PQ schemas0 schemas1 io) where - - manipulateParams - (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) = - PQ $ \ (K conn) -> do - let - toParam' encoding = - (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary) - params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params)) - q' = q <> ";" - resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary - case resultMaybe of - Nothing -> throw $ ResultException - "manipulateParams: LibPQ.execParams returned no results" - Just result -> do - okResult_ result - return $ K (K result) - - traversePrepared - (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) = - PQ $ \ (K conn) -> liftIO $ do - let temp = "temporary_statement" - prepResultMaybe <- LibPQ.prepare conn temp q Nothing - case prepResultMaybe of - Nothing -> throw $ ResultException - "traversePrepared: LibPQ.prepare returned no results" - Just prepResult -> okResult_ prepResult - results <- for list $ \ params -> do - let - toParam' encoding = (encodingBytes encoding,LibPQ.Binary) - params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params)) - resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary - case resultMaybe of - Nothing -> throw $ ResultException - "traversePrepared: LibPQ.execParams returned no results" - Just result -> do - okResult_ result - return $ K result - deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") - case deallocResultMaybe of - Nothing -> throw $ ResultException - "traversePrepared: LibPQ.exec DEALLOCATE returned no results" - Just deallocResult -> okResult_ deallocResult - return (K results) - - traversePrepared_ - (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) = - PQ $ \ (K conn) -> liftIO $ do - let temp = "temporary_statement" - prepResultMaybe <- LibPQ.prepare conn temp q Nothing - case prepResultMaybe of - Nothing -> throw $ ResultException - "traversePrepared_: LibPQ.prepare returned no results" - Just prepResult -> okResult_ prepResult - for_ list $ \ params -> do - let - toParam' encoding = (encodingBytes encoding, LibPQ.Binary) - params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params)) - resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary - case resultMaybe of - Nothing -> throw $ ResultException - "traversePrepared_: LibPQ.execParams returned no results" - Just result -> okResult_ result - deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") - case deallocResultMaybe of - Nothing -> throw $ ResultException - "traversePrepared: LibPQ.exec DEALLOCATE returned no results" - Just deallocResult -> okResult_ deallocResult - return (K ()) - - liftPQ pq = PQ $ \ (K conn) -> do - y <- liftIO $ pq conn - return (K y) - -instance MonadPQ schemas m => MonadPQ schemas (IdentityT m) -instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m) -instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m) -instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m) -instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m) -instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m) -instance MonadPQ schemas m => MonadPQ schemas (MaybeT m) -instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m) -instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m) -instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m) -instance MonadPQ schemas m => MonadPQ schemas (ContT r m) - -instance (Monad m, schemas0 ~ schemas1) - => Applicative (PQ schemas0 schemas1 m) where - pure x = PQ $ \ _conn -> pure (K x) - (<*>) = pqAp - -instance (Monad m, schemas0 ~ schemas1) - => Monad (PQ schemas0 schemas1 m) where - return = pure - (>>=) = flip pqBind - -instance (Monad m, schemas0 ~ schemas1) - => Fail.MonadFail (PQ schemas0 schemas1 m) where - fail = Fail.fail - -instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where - hoist f (PQ pq) = PQ (f . pq) - -instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where - lift m = PQ $ \ _conn -> do - x <- m - return (K x) - -instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where - embed f (PQ pq) = PQ $ \ conn -> do - evalPQ (f (pq conn)) conn - -instance (MonadIO m, schema0 ~ schema1) - => MonadIO (PQ schema0 schema1 m) where - liftIO = lift . liftIO - -instance (MonadUnliftIO m, schemas0 ~ schemas1) - => MonadUnliftIO (PQ schemas0 schemas1 m) where - withRunInIO - :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b) - -> PQ schemas0 schema1 m b - withRunInIO inner = PQ $ \conn -> - withRunInIO $ \(run :: (forall x . m x -> IO x)) -> - K <$> inner (\pq -> run $ unK <$> unPQ pq conn) - --- | Get a row corresponding to a given row number from a `LibPQ.Result`, --- throwing an exception if the row number is out of bounds. -getRow - :: (FromRow columns y, MonadIO io) - => LibPQ.Row - -- ^ row number - -> K LibPQ.Result columns - -- ^ result - -> io y -getRow r (K result :: K LibPQ.Result columns) = liftIO $ do - numRows <- LibPQ.ntuples result - when (numRows < r) $ throw $ ResultException $ - "getRow: expected at least " <> pack (show r) <> "rows but only saw " - <> pack (show numRows) - let len = fromIntegral (lengthSList (Proxy @columns)) - row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1] - case fromList row' of - Nothing -> throw $ ResultException "getRow: found unexpected length" - Just row -> case fromRow @columns row of - Left parseError -> throw $ ParseException $ "getRow: " <> parseError - Right y -> return y - --- | Intended to be used for unfolding in streaming libraries, `nextRow` --- takes a total number of rows (which can be found with `ntuples`) --- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`, --- otherwise returning the row along with the next row number. -nextRow - :: (FromRow columns y, MonadIO io) - => LibPQ.Row -- ^ total number of rows - -> K LibPQ.Result columns -- ^ result - -> LibPQ.Row -- ^ row number - -> io (Maybe (LibPQ.Row,y)) -nextRow total (K result :: K LibPQ.Result columns) r - = liftIO $ if r >= total then return Nothing else do - let len = fromIntegral (lengthSList (Proxy @columns)) - row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1] - case fromList row' of - Nothing -> throw $ ResultException "nextRow: found unexpected length" - Just row -> case fromRow @columns row of - Left parseError -> throw $ ParseException $ "nextRow: " <> parseError - Right y -> return $ Just (r+1, y) - --- | Get all rows from a `LibPQ.Result`. -getRows - :: (FromRow columns y, MonadIO io) - => K LibPQ.Result columns -- ^ result - -> io [y] -getRows (K result :: K LibPQ.Result columns) = liftIO $ do - let len = fromIntegral (lengthSList (Proxy @columns)) - numRows <- LibPQ.ntuples result - for [0 .. numRows - 1] $ \ r -> do - row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1] - case fromList row' of - Nothing -> throw $ ResultException "getRows: found unexpected length" - Just row -> case fromRow @columns row of - Left parseError -> throw $ ParseException $ "getRows: " <> parseError - Right y -> return y - --- | Get the first row if possible from a `LibPQ.Result`. -firstRow - :: (FromRow columns y, MonadIO io) - => K LibPQ.Result columns -- ^ result - -> io (Maybe y) -firstRow (K result :: K LibPQ.Result columns) = liftIO $ do - numRows <- LibPQ.ntuples result - if numRows <= 0 then return Nothing else do - let len = fromIntegral (lengthSList (Proxy @columns)) - row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1] - case fromList row' of - Nothing -> throw $ ResultException "firstRow: found unexpected length" - Just row -> case fromRow @columns row of - Left parseError -> throw $ ParseException $ "firstRow: " <> parseError - Right y -> return $ Just y - --- | Lifts actions on results from @LibPQ@. -liftResult - :: MonadIO io - => (LibPQ.Result -> IO x) - -> K LibPQ.Result results -> io x -liftResult f (K result) = liftIO $ f result - --- | Returns the number of rows (tuples) in the query result. -ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row -ntuples = liftResult LibPQ.ntuples - --- | Returns the result status of the command. -resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus -resultStatus = liftResult LibPQ.resultStatus - --- | Returns the error message most recently generated by an operation --- on the connection. -resultErrorMessage - :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString) -resultErrorMessage = liftResult LibPQ.resultErrorMessage - --- | Returns the error code most recently generated by an operation --- on the connection. --- --- https://www.postgresql.org/docs/current/static/errcodes-appendix.html -resultErrorCode - :: MonadIO io - => K LibPQ.Result results - -> io (Maybe ByteString) -resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate) - --- | the state of LibPQ -data PQState = PQState - { sqlExecStatus :: LibPQ.ExecStatus - , sqlStateCode :: Maybe ByteString - -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html - , sqlErrorMessage :: Maybe ByteString - } deriving (Eq, Show) - --- | `Exception`s that can be thrown by Squeal. -data SquealException - = PQException PQState - | ResultException Text - | ParseException Text - deriving (Eq, Show) -instance Exception SquealException - -okResult_ :: MonadIO io => LibPQ.Result -> io () -okResult_ result = liftIO $ do - status <- LibPQ.resultStatus result - case status of - LibPQ.CommandOk -> return () - LibPQ.TuplesOk -> return () - _ -> do - stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate - msg <- LibPQ.resultErrorMessage result - throw . PQException $ PQState status stateCode msg - --- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk` --- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`. -okResult :: MonadIO io => K LibPQ.Result row -> io () -okResult = okResult_ . unK - --- | Catch `SquealException`s. -catchSqueal - :: MonadUnliftIO io - => io a - -> (SquealException -> io a) -- ^ handler - -> io a -catchSqueal = catch - --- | Handle `SquealException`s. -handleSqueal - :: MonadUnliftIO io - => (SquealException -> io a) -- ^ handler - -> io a -> io a -handleSqueal = handle - --- | `Either` return a `SquealException` or a result. -trySqueal - :: MonadUnliftIO io - => io a - -> io (Either SquealException a) -trySqueal = try diff --git a/src/Squeal/PostgreSQL/Pool.hs b/src/Squeal/PostgreSQL/Pool.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Pool.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Pool -Description: Connection pools -Copyright: (c) Eitan Chatav, 2017 -Maintainer: eitan@morphism.tech -Stability: experimental - -Connection pools. - -Typical use case would be to create your pool using `createConnectionPool` -and run anything that requires the pool connection with `usingConnectionPool`. - -Here's a simplified example: - ->>> import Squeal.PostgreSQL - ->>> :{ -do - let - query :: Query_ (Public '[]) () (Only Char) - query = values_ (literal 'a' `as` #fromOnly) - pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10 - chr <- usingConnectionPool pool $ do - result <- runQuery query - Just (Only a) <- firstRow result - return a - destroyConnectionPool pool - putChar chr -:} -a --} - -{-# LANGUAGE - DeriveFunctor - , FlexibleContexts - , FlexibleInstances - , InstanceSigs - , MultiParamTypeClasses - , RankNTypes - , ScopedTypeVariables - , TypeFamilies - , TypeInType - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Pool - ( -- * Pools - Pool - , createConnectionPool - , usingConnectionPool - , destroyConnectionPool - ) where - -import Data.ByteString -import Data.Time -import Generics.SOP (K(..), unK) -import UnliftIO (MonadUnliftIO (..)) -import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource) - -import Squeal.PostgreSQL.PQ - --- | Create a striped pool of connections. --- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible. -createConnectionPool - :: MonadUnliftIO io - => ByteString - -- ^ The passed string can be empty to use all default parameters, or it can - -- contain one or more parameter settings separated by whitespace. - -- Each parameter setting is in the form keyword = value. Spaces around the equal - -- sign are optional. To write an empty value or a value containing spaces, - -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and - -- backslashes within the value must be escaped with a backslash, i.e., ' and \. - -> Int - -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1. - -> NominalDiffTime - -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds. - -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals. - -> Int - -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1. - -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available. - -> io (Pool (K Connection schemas)) -createConnectionPool conninfo stripes idle maxResrc = - createPool (connectdb conninfo) finish stripes idle maxResrc - -{-| -Temporarily take a connection from a `Pool`, perform an action with it, -and return it to the pool afterwards. - -If the pool has an idle connection available, it is used immediately. -Otherwise, if the maximum number of connections has not yet been reached, -a new connection is created and used. -If the maximum number of connections has been reached, this function blocks -until a connection becomes available. --} -usingConnectionPool - :: MonadUnliftIO io - => Pool (K Connection schemas) -- ^ pool - -> PQ schemas schemas io x -- ^ session - -> io x -usingConnectionPool pool (PQ session) = unK <$> withResource pool session - -{- | -Destroy all connections in all stripes in the pool. -Note that this will ignore any exceptions in the destroy function. - -This function is useful when you detect that all connections -in the pool are broken. For example after a database has been -restarted all connections opened before the restart will be broken. -In that case it's better to close those connections so that -`usingConnectionPool` won't take a broken connection from the pool -but will open a new connection instead. - -Another use-case for this function is that when you know you are done -with the pool you can destroy all idle connections immediately -instead of waiting on the garbage collector to destroy them, -thus freeing up those connections sooner. --} -destroyConnectionPool - :: MonadUnliftIO io - => Pool (K Connection schemas) -- ^ pool - -> io () -destroyConnectionPool = destroyAllResources 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 @@ -1,16 +1,17 @@ {-| Module: Squeal.PostgreSQL.Query -Description: Squeal queries +Description: structured query language Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Squeal queries. +structured query language -} {-# LANGUAGE ConstraintKinds , DeriveGeneric + , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs @@ -24,25 +25,17 @@ , StandaloneDeriving , TypeApplications , TypeFamilies - , TypeInType + , DataKinds + , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances #-} module Squeal.PostgreSQL.Query - ( -- * Queries - Query_ - , Query (..) - -- ** Select - , select - , select_ - , selectDistinct - , selectDistinct_ - , Selection (..) - -- ** Values - , values - , values_ + ( -- * Query + Query (..) + , Query_ -- ** Set Operations , union , unionAll @@ -50,54 +43,17 @@ , intersectAll , except , exceptAll - -- ** With - , With (..) - , CommonTableExpression (..) - , withRecursive - -- * Table Expressions - , TableExpression (..) - , from - , where_ - , groupBy - , having - , limit - , offset - -- * From Clauses - , FromClause (..) - , table - , subquery - , view - , common - , crossJoin - , innerJoin - , leftOuterJoin - , rightOuterJoin - , fullOuterJoin - -- * Grouping - , By (..) - , GroupByClause (..) - , HavingClause (..) ) where import Control.DeepSeq import Data.ByteString (ByteString) import Data.Kind (Type) -import Data.String -import Data.Word -import Generics.SOP hiding (from) -import GHC.TypeLits import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.Expression.Window -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.PG +import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Schema +import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL @@ -112,44 +68,13 @@ The general `Query` type is parameterized by -* @outer :: FromType@ - outer scope for a correlated subquery, -* @commons :: FromType@ - scope for all `common` table expressions, -* @schemas :: SchemasType@ - scope for all `table`s and `view`s, -* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, +* @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 - (outer :: FromType) - (commons :: FromType) - (schemas :: SchemasType) - (params :: [NullityType]) - (row :: RowType) - = UnsafeQuery { renderQuery :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery -{- | -The top level `Query_` type is parameterized by a @schemas@ `SchemasType`, -against which the query is type-checked, an input @parameters@ Haskell `Type`, -and an ouput row Haskell `Type`. - -A top-level query can be run -using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@ -using `Squeal.PostgreSQL.PQ.runQuery`. - -Generally, @parameters@ 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: @@ -157,9 +82,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" @@ -167,23 +92,23 @@ >>> :{ 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)) +SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > (0 :: int4))) subquery: >>> :{ 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" @@ -191,9 +116,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 @@ -201,9 +126,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)) @@ -211,23 +136,23 @@ >>> :{ 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) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1) +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)) sorted query: >>> :{ 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 @@ -244,8 +169,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] @@ -259,19 +184,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 ) @@ -280,7 +203,7 @@ (#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") @@ -288,11 +211,11 @@ >>> :{ 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" @@ -300,77 +223,140 @@ >>> :{ let - query :: Query_ schemas () (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', TRUE), (E'false', FALSE)) AS t ("col1", "col2") +SELECT * FROM (VALUES ((E'true' :: text), TRUE), ((E'false' :: text), FALSE)) AS t ("col1", "col2") set operations: >>> :{ 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 .&& just_ (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_ - (schemas :: SchemasType) - (parameters :: Type) + (db :: SchemasType) + (params :: Type) (row :: Type) where - Query_ schemas params row = - Query '[] '[] schemas (TuplePG params) (RowPG row) + Query_ db params row = + Query '[] '[] db (TuplePG params) (RowPG row) -- | The results of two queries can be combined using the set operation -- `union`. Duplicate rows are eliminated. union - :: Query outer commons schemas params columns - -> Query outer commons schemas params columns - -> Query outer commons schemas params columns + :: Query lat with db params columns -- ^ + -> Query lat with db params columns + -> Query lat with db params columns q1 `union` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "UNION" @@ -379,9 +365,9 @@ -- | The results of two queries can be combined using the set operation -- `unionAll`, the disjoint union. Duplicate rows are retained. unionAll - :: Query outer commons schemas params columns - -> Query outer commons schemas params columns - -> Query outer commons schemas params columns + :: Query lat with db params columns -- ^ + -> Query lat with db params columns + -> Query lat with db params columns q1 `unionAll` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "UNION" <+> "ALL" @@ -390,9 +376,9 @@ -- | The results of two queries can be combined using the set operation -- `intersect`, the intersection. Duplicate rows are eliminated. intersect - :: Query outer commons schemas params columns - -> Query outer commons schemas params columns - -> Query outer commons schemas params columns + :: Query lat with db params columns -- ^ + -> Query lat with db params columns + -> Query lat with db params columns q1 `intersect` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "INTERSECT" @@ -401,9 +387,9 @@ -- | The results of two queries can be combined using the set operation -- `intersectAll`, the intersection. Duplicate rows are retained. intersectAll - :: Query outer commons schemas params columns - -> Query outer commons schemas params columns - -> Query outer commons schemas params columns + :: Query lat with db params columns -- ^ + -> Query lat with db params columns + -> Query lat with db params columns q1 `intersectAll` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "INTERSECT" <+> "ALL" @@ -412,9 +398,9 @@ -- | The results of two queries can be combined using the set operation -- `except`, the set difference. Duplicate rows are eliminated. except - :: Query outer commons schemas params columns - -> Query outer commons schemas params columns - -> Query outer commons schemas params columns + :: Query lat with db params columns -- ^ + -> Query lat with db params columns + -> Query lat with db params columns q1 `except` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "EXCEPT" @@ -423,624 +409,10 @@ -- | The results of two queries can be combined using the set operation -- `exceptAll`, the set difference. Duplicate rows are retained. exceptAll - :: Query outer commons schemas params columns - -> Query outer commons schemas params columns - -> Query outer commons schemas params columns + :: Query lat with db params columns -- ^ + -> Query lat with db params columns + -> Query lat with db params columns q1 `exceptAll` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "EXCEPT" <+> "ALL" <+> parenthesized (renderSQL q2) - -{----------------------------------------- -SELECT queries ------------------------------------------} - -{- | The simplest kinds of `Selection` are `Star` and `DotStar` which -emits all columns that a `TableExpression` produces. A select `List` -is a list of `Expression`s. A `Selection` could be a list of -`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can -be selected with `Also`. --} -data Selection outer commons grp schemas params from row where - Star - :: HasUnique tab from row - => Selection outer commons 'Ungrouped schemas params from row - -- ^ `HasUnique` table in the `FromClause` - DotStar - :: Has tab from row - => Alias tab - -- ^ `Has` table with `Alias` - -> Selection outer commons 'Ungrouped schemas params from row - List - :: SListI row - => NP (Aliased (Expression outer commons grp schemas params from)) row - -- ^ `NP` list of `Aliased` `Expression`s - -> Selection outer commons grp schemas params from row - Over - :: SListI row - => NP (Aliased (WindowFunction outer commons grp schemas params from)) row - -- ^ `NP` list of `Aliased` `WindowFunction`s - -> WindowDefinition outer commons grp schemas params from - -> Selection outer commons grp schemas params from row - Also - :: Selection outer commons grp schemas params from right - -- ^ `Additional` `Selection` - -> Selection outer commons grp schemas params from left - -> Selection outer commons grp schemas params from (Join left right) -instance Additional (Selection outer commons grp schemas params from) where - also = Also -instance (KnownSymbol col, row ~ '[col ::: ty]) - => Aliasable col - (Expression outer commons grp schemas params from ty) - (Selection outer commons grp schemas params from row) where - expr `as` col = List (expr `as` col) -instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty]) - => IsQualified tab col - (Selection outer commons 'Ungrouped schemas params from row1) where - tab ! col = tab ! col `as` col -instance - ( Has tab (Join outer from) row0 - , Has col row0 ty - , row1 ~ '[col ::: ty] - , GroupedBy tab col bys ) - => IsQualified tab col - (Selection outer commons ('Grouped bys) schemas params from row1) where - tab ! col = tab ! col `as` col -instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty]) - => IsLabel col - (Selection outer commons 'Ungrouped schemas params from row1) where - fromLabel = fromLabel @col `as` Alias -instance - ( HasUnique tab (Join outer from) row0 - , Has col row0 ty - , row1 ~ '[col ::: ty] - , GroupedBy tab col bys ) - => IsLabel col - (Selection outer commons ('Grouped bys) schemas params from row1) where - fromLabel = fromLabel @col `as` Alias - -instance RenderSQL (Selection outer commons grp schemas params from row) where - renderSQL = \case - List list -> renderCommaSeparated (renderAliased renderSQL) list - Star -> "*" - DotStar tab -> renderSQL tab <> ".*" - Also right left -> renderSQL left <> ", " <> renderSQL right - Over winFns winDef -> - let - renderOver - :: Aliased (WindowFunction outer commons grp schemas params from) field - -> ByteString - renderOver (winFn `As` col) = renderSQL winFn - <+> "OVER" <+> parenthesized (renderSQL winDef) - <+> "AS" <+> renderSQL col - in - renderCommaSeparated renderOver winFns - -instance IsString - (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where - fromString str = fromString str `as` Alias - --- | the `TableExpression` in the `select` command constructs an intermediate --- virtual table by possibly combining tables, views, eliminating rows, --- grouping, etc. This table is finally passed on to processing by --- the select list. The `Selection` determines which columns of --- the intermediate table are actually output. -select - :: (SListI row, row ~ (x ': xs)) - => Selection outer commons grp schemas params from row - -- ^ selection - -> TableExpression outer commons grp schemas params from - -- ^ intermediate virtual table - -> Query outer commons schemas params row -select selection tabexpr = UnsafeQuery $ - "SELECT" - <+> renderSQL selection - <+> renderSQL tabexpr - --- | Like `select` but takes an `NP` list of `Expression`s instead --- of a general `Selection`. -select_ - :: (SListI row, row ~ (x ': xs)) - => NP (Aliased (Expression outer commons grp schemas params from)) row - -- ^ select list - -> TableExpression outer commons grp schemas params from - -- ^ intermediate virtual table - -> Query outer commons schemas params row -select_ = select . List - --- | After the select list has been processed, the result table can --- be subject to the elimination of duplicate rows using `selectDistinct`. -selectDistinct - :: (SListI columns, columns ~ (col ': cols)) - => Selection outer commons 'Ungrouped schemas params from columns - -- ^ selection - -> TableExpression outer commons 'Ungrouped schemas params from - -- ^ intermediate virtual table - -> Query outer commons schemas params columns -selectDistinct selection tabexpr = UnsafeQuery $ - "SELECT DISTINCT" - <+> renderSQL selection - <+> renderSQL tabexpr - --- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead --- of a general `Selection`. -selectDistinct_ - :: (SListI columns, columns ~ (col ': cols)) - => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns - -- ^ select list - -> TableExpression outer commons 'Ungrouped schemas params from - -- ^ intermediate virtual table - -> Query outer commons schemas params columns -selectDistinct_ = selectDistinct . List - --- | `values` computes a row value or set of row values --- specified by value expressions. It is most commonly used --- to generate a “constant table” within a larger command, --- but it can be used on its own. --- --- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext] --- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row --- >>> printSQL query --- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b") -values - :: SListI cols - => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols - -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols] - -- ^ When more than one row is specified, all the rows must - -- must have the same number of elements - -> Query outer commons schemas params cols -values rw rws = UnsafeQuery $ "SELECT * FROM" - <+> parenthesized ( - "VALUES" - <+> commaSeparated - ( parenthesized - . renderCommaSeparated renderValuePart <$> rw:rws ) - ) <+> "AS t" - <+> parenthesized (renderCommaSeparated renderAliasPart rw) - where - renderAliasPart, renderValuePart - :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString - renderAliasPart (_ `As` name) = renderSQL name - renderValuePart (value `As` _) = renderSQL value - --- | `values_` computes a row value or set of row values --- specified by value expressions. -values_ - :: SListI cols - => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols - -- ^ one row of values - -> Query outer commons schemas params cols -values_ rw = values rw [] - -{----------------------------------------- -Table Expressions ------------------------------------------} - --- | 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 --- 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 - (outer :: FromType) - (commons :: FromType) - (grp :: Grouping) - (schemas :: SchemasType) - (params :: [NullityType]) - (from :: FromType) - = TableExpression - { fromClause :: FromClause outer commons schemas params from - -- ^ A table reference that can be a table name, or a derived table such - -- as a subquery, a @JOIN@ construct, or complex combinations of these. - , whereClause :: [Condition outer commons 'Ungrouped schemas params from] - -- ^ optional search coditions, combined with `.&&`. After the processing - -- of the `fromClause` is done, each row of the derived virtual table - -- is checked against the search condition. If the result of the - -- condition is true, the row is kept in the output table, - -- otherwise it is discarded. The search condition typically references - -- at least one column of the table generated in the `fromClause`; - -- this is not required, but otherwise the WHERE clause will - -- be fairly useless. - , groupByClause :: GroupByClause grp from - -- ^ The `groupByClause` is used to group together those rows in a table - -- that have the same values in all the columns listed. The order in which - -- the columns are listed does not matter. The effect is to combine each - -- set of rows having common values into one group row that represents all - -- rows in the group. This is done to eliminate redundancy in the output - -- and/or compute aggregates that apply to these groups. - , havingClause :: HavingClause outer commons grp schemas params from - -- ^ If a table has been grouped using `groupBy`, but only certain groups - -- are of interest, the `havingClause` can be used, much like a - -- `whereClause`, to eliminate groups from the result. Expressions in the - -- `havingClause` can refer both to grouped expressions and to ungrouped - -- expressions (which necessarily involve an aggregate function). - , orderByClause :: [SortExpression outer commons grp schemas params from] - -- ^ The `orderByClause` is for optional sorting. When more than one - -- `SortExpression` is specified, the later (right) values are used to sort - -- rows that are equal according to the earlier (left) values. - , limitClause :: [Word64] - -- ^ The `limitClause` is combined with `min` to give a limit count - -- if nonempty. If a limit count is given, no more than that many rows - -- will be returned (but possibly fewer, if the query itself yields - -- fewer rows). - , offsetClause :: [Word64] - -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count - -- 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. - } deriving (GHC.Generic) - --- | Render a `TableExpression` -instance RenderSQL (TableExpression outer commons grp schemas params from) where - renderSQL - (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat - [ "FROM ", renderSQL frm' - , renderWheres whs' - , renderSQL grps' - , renderSQL hvs' - , renderOrderByClause srts' - , renderLimits lims' - , renderOffsets offs' ] - where - renderWheres = \case - [] -> "" - wh:[] -> " WHERE" <+> renderSQL wh - wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs) - renderOrderByClause = \case - [] -> "" - srts -> " ORDER BY" - <+> commaSeparated (renderSQL <$> srts) - renderLimits = \case - [] -> "" - lims -> " LIMIT" <+> fromString (show (minimum lims)) - renderOffsets = \case - [] -> "" - offs -> " OFFSET" <+> fromString (show (sum offs)) - --- | 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, --- or complex combinations of these. A `from` may be transformed by `where_`, --- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator --- to match the left-to-right sequencing of their placement in SQL. -from - :: FromClause outer commons schemas params from -- ^ table reference - -> TableExpression outer commons 'Ungrouped schemas params from -from tab = TableExpression tab [] NoGroups NoHaving [] [] [] - --- | A `where_` is an endomorphism of `TableExpression`s which adds a --- search condition to the `whereClause`. -where_ - :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition - -> TableExpression outer commons grp schemas params from - -> TableExpression outer commons grp schemas params from -where_ wh rels = rels {whereClause = wh : whereClause rels} - --- | A `groupBy` is a transformation of `TableExpression`s which switches --- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform --- a "grand total" aggregation query. -groupBy - :: SListI bys - => NP (By from) bys -- ^ grouped columns - -> TableExpression outer commons 'Ungrouped schemas params from - -> TableExpression outer commons ('Grouped bys) schemas params from -groupBy bys rels = TableExpression - { fromClause = fromClause rels - , whereClause = whereClause rels - , groupByClause = Group bys - , havingClause = Having [] - , orderByClause = [] - , limitClause = limitClause rels - , offsetClause = offsetClause rels - } - --- | A `having` is an endomorphism of `TableExpression`s which adds a --- search condition to the `havingClause`. -having - :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition - -> TableExpression outer commons ('Grouped bys) schemas params from - -> TableExpression outer commons ('Grouped bys) schemas params from -having hv rels = rels - { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) } - -instance OrderBy TableExpression where - orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts} - --- | A `limit` is an endomorphism of `TableExpression`s which adds to the --- `limitClause`. -limit - :: Word64 -- ^ limit parameter - -> TableExpression outer commons grp schemas params from - -> TableExpression outer commons grp schemas params from -limit lim rels = rels {limitClause = lim : limitClause rels} - --- | An `offset` is an endomorphism of `TableExpression`s which adds to the --- `offsetClause`. -offset - :: Word64 -- ^ offset parameter - -> TableExpression outer commons grp schemas params from - -> TableExpression outer commons grp schemas params from -offset off rels = rels {offsetClause = off : offsetClause rels} - -{----------------------------------------- -FROM clauses ------------------------------------------} - -{- | -A `FromClause` can be a table name, or a derived table such -as a subquery, a @JOIN@ construct, or complex combinations of these. --} -newtype FromClause outer commons schemas params from - = UnsafeFromClause { renderFromClause :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (FromClause outer commons schemas params from) where - renderSQL = renderFromClause - --- | A real `table` is a table from the database. -table - :: (Has sch schemas schema, Has tab schema ('Table table)) - => Aliased (QualifiedAlias sch) (alias ::: tab) - -> FromClause outer commons schemas params '[alias ::: TableToRow table] -table (tab `As` alias) = UnsafeFromClause $ - renderSQL tab <+> "AS" <+> renderSQL alias - --- | `subquery` derives a table from a `Query`. -subquery - :: Aliased (Query outer commons schemas params) query - -> FromClause outer commons schemas params '[query] -subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL) - --- | `view` derives a table from a `View`. -view - :: (Has sch schemas schema, Has vw schema ('View view)) - => Aliased (QualifiedAlias sch) (alias ::: vw) - -> FromClause outer commons schemas params '[alias ::: view] -view (vw `As` alias) = UnsafeFromClause $ - renderSQL vw <+> "AS" <+> renderSQL alias - --- | `common` derives a table from a common table expression. -common - :: Has cte commons common - => Aliased Alias (alias ::: cte) - -> FromClause outer commons schemas params '[alias ::: common] -common (cte `As` alias) = UnsafeFromClause $ - renderSQL cte <+> "AS" <+> renderSQL alias - -instance Additional (FromClause outer commons schemas params) where - also right left = UnsafeFromClause $ - renderSQL left <> ", " <> renderSQL right - -{- | -@left & crossJoin right@. For every possible combination of rows from -@left@ and @right@ (i.e., a Cartesian product), the joined table will contain -a row consisting of all columns in @left@ followed by all columns in @right@. -If the tables have @n@ and @m@ rows respectively, the joined table will -have @n * m@ rows. --} -crossJoin - :: FromClause outer commons schemas params right - -- ^ right - -> FromClause outer commons schemas params left - -- ^ left - -> FromClause outer commons schemas params (Join left right) -crossJoin right left = UnsafeFromClause $ - renderSQL left <+> "CROSS JOIN" <+> renderSQL right - -{- | @left & innerJoin right on@. The joined table is filtered by -the @on@ condition. --} -innerJoin - :: FromClause outer commons schemas params right - -- ^ right - -> Condition outer commons 'Ungrouped schemas params (Join left right) - -- ^ @on@ condition - -> FromClause outer commons schemas params left - -- ^ left - -> FromClause outer commons schemas params (Join left right) -innerJoin right on left = UnsafeFromClause $ - renderSQL left <+> "INNER JOIN" <+> renderSQL right - <+> "ON" <+> renderSQL on - -{- | @left & leftOuterJoin right on@. First, an inner join is performed. - Then, for each row in @left@ that does not satisfy the @on@ condition with - any row in @right@, a joined row is added with null values in columns of @right@. - Thus, the joined table always has at least one row for each row in @left@. --} -leftOuterJoin - :: FromClause outer commons schemas params right - -- ^ right - -> Condition outer commons 'Ungrouped schemas params (Join left right) - -- ^ @on@ condition - -> FromClause outer commons schemas params left - -- ^ left - -> FromClause outer commons schemas params (Join left (NullifyFrom right)) -leftOuterJoin right on left = UnsafeFromClause $ - renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right - <+> "ON" <+> renderSQL on - -{- | @left & rightOuterJoin right on@. First, an inner join is performed. - Then, for each row in @right@ that does not satisfy the @on@ condition with - any row in @left@, a joined row is added with null values in columns of @left@. - This is the converse of a left join: the result table will always - have a row for each row in @right@. --} -rightOuterJoin - :: FromClause outer commons schemas params right - -- ^ right - -> Condition outer commons 'Ungrouped schemas params (Join left right) - -- ^ @on@ condition - -> FromClause outer commons schemas params left - -- ^ left - -> FromClause outer commons schemas params (Join (NullifyFrom left) right) -rightOuterJoin right on left = UnsafeFromClause $ - renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right - <+> "ON" <+> renderSQL on - -{- | @left & fullOuterJoin right on@. First, an inner join is performed. - Then, for each row in @left@ that does not satisfy the @on@ condition with - any row in @right@, a joined row is added with null values in columns of @right@. - Also, for each row of @right@ that does not satisfy the join condition - with any row in @left@, a joined row with null values in the columns of @left@ - is added. --} -fullOuterJoin - :: FromClause outer commons schemas params right - -- ^ right - -> Condition outer commons 'Ungrouped schemas params (Join left right) - -- ^ @on@ condition - -> FromClause outer commons schemas params left - -- ^ left - -> FromClause outer commons schemas params - (Join (NullifyFrom left) (NullifyFrom right)) -fullOuterJoin right on left = UnsafeFromClause $ - renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right - <+> "ON" <+> renderSQL on - -{----------------------------------------- -Grouping ------------------------------------------} - --- | `By`s are used in `groupBy` to reference a list of columns which are then --- used to group together those rows in a table that have the same values --- in all the columns listed. @By \#col@ will reference an unambiguous --- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table --- qualified column @tab.col@. -data By - (from :: FromType) - (by :: (Symbol,Symbol)) where - By1 - :: (HasUnique table from columns, Has column columns ty) - => Alias column - -> By from '(table, column) - By2 - :: (Has table from columns, Has column columns ty) - => Alias table - -> Alias column - -> By from '(table, column) -deriving instance Show (By from by) -deriving instance Eq (By from by) -deriving instance Ord (By from by) -instance RenderSQL (By from by) where - renderSQL = \case - By1 column -> renderSQL column - By2 rel column -> renderSQL rel <> "." <> renderSQL column - -instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col)) - => IsLabel col (By rels by) where fromLabel = By1 fromLabel -instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)]) - => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil -instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col)) - => IsQualified rel col (By rels by) where (!) = By2 -instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)]) - => IsQualified rel col (NP (By rels) bys) where - rel ! col = By2 rel col :* Nil - --- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`. --- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`. --- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be --- done on @NoGroups@ while all output `Expression`s must be aggregated --- in @Group Nil@. In general, all output `Expression`s in the --- complement of @bys@ must be aggregated in @Group bys@. -data GroupByClause grp from where - NoGroups :: GroupByClause 'Ungrouped from - Group - :: SListI bys - => NP (By from) bys - -> GroupByClause ('Grouped bys) from - --- | Renders a `GroupByClause`. -instance RenderSQL (GroupByClause grp from) where - renderSQL = \case - NoGroups -> "" - Group Nil -> "" - Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys - --- | A `HavingClause` is used to eliminate groups that are not of interest. --- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped` --- `TableExpression` must use `Having` whose conditions are combined with --- `.&&`. -data HavingClause outer commons grp schemas params from where - NoHaving :: HavingClause outer commons 'Ungrouped schemas params from - Having - :: [Condition outer commons ('Grouped bys) schemas params from] - -> HavingClause outer commons ('Grouped bys) schemas params from -deriving instance Show (HavingClause outer commons grp schemas params from) -deriving instance Eq (HavingClause outer commons grp schemas params from) -deriving instance Ord (HavingClause outer commons grp schemas params from) - --- | Render a `HavingClause`. -instance RenderSQL (HavingClause outer commons grp schemas params from) where - renderSQL = \case - NoHaving -> "" - Having [] -> "" - Having conditions -> - " HAVING" <+> commaSeparated (renderSQL <$> conditions) - --- | A `CommonTableExpression` is an auxiliary statement in a `with` clause. -data CommonTableExpression statement - (schemas :: SchemasType) - (params :: [NullityType]) - (commons0 :: FromType) - (commons1 :: FromType) where - CommonTableExpression - :: Aliased (statement commons schemas params) (cte ::: common) - -> CommonTableExpression statement schemas params commons (cte ::: common ': commons) -instance - ( KnownSymbol cte - , commons1 ~ (cte ::: common ': commons) - ) => Aliasable cte - (statement commons schemas params common) - (CommonTableExpression statement schemas params commons commons1) where - statement `as` cte = CommonTableExpression (statement `as` cte) -instance - ( KnownSymbol cte - , commons1 ~ (cte ::: common ': commons) - ) => Aliasable cte - (statement commons schemas params common) - (AlignedList (CommonTableExpression statement schemas params) commons commons1) where - statement `as` cte = single (statement `as` cte) - -instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL - (CommonTableExpression statement schemas params commons0 commons1) where - renderSQL (CommonTableExpression (statement `As` cte)) = - renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement) - --- | `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. -class With statement where - with - :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1 - -- ^ common table expressions - -> statement commons1 schemas params row - -- ^ larger query - -> statement commons0 schemas params row -instance With (Query outer) where - with Done query = query - with ctes query = UnsafeQuery $ - "WITH" <+> renderSQL ctes <+> renderSQL query - -{- | ->>> 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 -:} -WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t" --} -withRecursive - :: Aliased (Query outer (recursive ': commons) schemas params) recursive - -> Query outer (recursive ': commons) schemas params row - -> Query outer commons schemas params row -withRecursive (recursive `As` cte) query = UnsafeQuery $ - "WITH RECURSIVE" <+> renderSQL cte - <+> "AS" <+> parenthesized (renderSQL recursive) - <+> renderSQL query diff --git a/src/Squeal/PostgreSQL/Query/From.hs b/src/Squeal/PostgreSQL/Query/From.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/From.hs @@ -0,0 +1,115 @@ +{-| +Module: Squeal.PostgreSQL.Query.From +Description: from clauses +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +from clauses +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.From + ( -- * From Clause + FromClause (..) + , table + , subquery + , view + , common + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) + +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{----------------------------------------- +FROM clauses +-----------------------------------------} + +{- | +A `FromClause` can be a table name, or a derived table such +as a subquery, a @JOIN@ construct, or complex combinations of these. +-} +newtype FromClause + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (from :: FromType) + = UnsafeFromClause { renderFromClause :: ByteString } + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (FromClause lat with db params from) where + renderSQL = renderFromClause + +-- | A real `table` is a table from the database. +table + :: (Has sch db schema, Has tab schema ('Table table)) + => Aliased (QualifiedAlias sch) (alias ::: tab) -- ^ (renamable) table alias + -> FromClause lat with db params '[alias ::: TableToRow table] +table (tab `As` alias) = UnsafeFromClause $ + renderSQL tab <+> "AS" <+> renderSQL alias + +{- | `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` + -> FromClause lat with db params '[query] +subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL) + +-- | `view` derives a table from a `View`. +view + :: (Has sch db schema, Has vw schema ('View view)) + => Aliased (QualifiedAlias sch) (alias ::: vw) -- ^ (renamable) view alias + -> FromClause lat with db params '[alias ::: view] +view (vw `As` alias) = UnsafeFromClause $ + renderSQL vw <+> "AS" <+> renderSQL alias + +-- | `common` derives a table from a common table expression. +common + :: Has cte with common + => Aliased Alias (alias ::: cte) -- ^ (renamable) common table expression alias + -> FromClause lat with db params '[alias ::: common] +common (cte `As` alias) = UnsafeFromClause $ + renderSQL cte <+> "AS" <+> renderSQL alias + +instance Additional (FromClause lat with db params) where + also right left = UnsafeFromClause $ + renderSQL left <> ", " <> renderSQL right diff --git a/src/Squeal/PostgreSQL/Query/From/Join.hs b/src/Squeal/PostgreSQL/Query/From/Join.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/From/Join.hs @@ -0,0 +1,295 @@ +{-| +Module: Squeal.PostgreSQL.Query.From.Join +Description: Squeal joins +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Squeal joins +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.From.Join + ( -- * Join + JoinItem (..) + , cross, crossJoin, crossJoinLateral + , inner, innerJoin, innerJoinLateral + , leftOuter, leftOuterJoin, leftOuterJoinLateral + , rightOuter, rightOuterJoin, rightOuterJoinLateral + , fullOuter, fullOuterJoin, fullOuterJoinLateral + ) where + +import Generics.SOP hiding (from) + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Query.From +import Squeal.PostgreSQL.Query.From.Set +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | +A `JoinItem` is the right hand side of a `cross`, +`inner`, `leftOuter`, `rightOuter`, `fullOuter` join of +`FromClause`s. +-} +data JoinItem + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (left :: FromType) + (right :: FromType) where + Join + :: FromClause lat with db params right + -- ^ A standard `Squeal.PostgreSQL.Query.Join`. + -- It is not allowed to reference columns provided + -- by preceding `FromClause` items. + -> JoinItem lat with db params left right + JoinLateral + :: Aliased (Query (Join lat left) with db params) query + -- ^ Subqueries can be preceded by `JoinLateral`. + -- This allows them to reference columns provided + -- by preceding `FromClause` items. + -> JoinItem lat with db params left '[query] + JoinFunction + :: SetFun db arg set + -- ^ Set returning functions can be preceded by `JoinFunction`. + -- This allows them to reference columns provided + -- by preceding `FromClause` items. + -> Expression 'Ungrouped lat with db params left arg + -- ^ argument + -> JoinItem lat with db params left '[set] + JoinFunctionN + :: SListI args + => SetFunN db args set + -- ^ Set returning multi-argument functions + -- 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 + -- ^ arguments + -> JoinItem lat with db params left '[set] +instance RenderSQL (JoinItem lat with db params left right) where + renderSQL = \case + Join tab -> "JOIN" <+> renderSQL tab + JoinLateral qry -> "JOIN LATERAL" <+> + renderAliased (parenthesized . renderSQL) qry + JoinFunction fun x -> "JOIN" <+> + renderSQL (fun (UnsafeExpression (renderSQL x))) + JoinFunctionN fun xs -> "JOIN" <+> + renderSQL (fun (SOP.hmap (UnsafeExpression . renderSQL) xs)) + +{- | +@left & cross (Join right)@. For every possible combination of rows from +@left@ and @right@ (i.e., a Cartesian product), the joined table will contain +a row consisting of all columns in @left@ followed by all columns in @right@. +If the tables have @n@ and @m@ rows respectively, the joined table will +have @n * m@ rows. +-} +cross + :: JoinItem lat with db params left right -- ^ right + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left right) +cross item tab = UnsafeFromClause $ + renderSQL tab <+> "CROSS" <+> renderSQL item + +{- | +@left & crossJoin right@. For every possible combination of rows from +@left@ and @right@ (i.e., a Cartesian product), the joined table will contain +a row consisting of all columns in @left@ followed by all columns in @right@. +If the tables have @n@ and @m@ rows respectively, the joined table will +have @n * m@ rows. +-} +crossJoin + :: FromClause lat with db params right -- ^ right + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left right) +crossJoin = cross . Join + +{- | +Like `crossJoin` with a `subquery` but allowed to reference columns provided +by preceding `FromClause` items. +-} +crossJoinLateral + :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left '[query]) +crossJoinLateral = cross . JoinLateral + +{- | @left & inner (Join right) on@. The joined table is filtered by +the @on@ condition. +-} +inner + :: JoinItem lat with db params left right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left right) +inner item on tab = UnsafeFromClause $ + renderSQL tab <+> "INNER" <+> renderSQL item <+> "ON" <+> renderSQL on + +{- | @left & innerJoin right on@. The joined table is filtered by +the @on@ condition. +-} +innerJoin + :: FromClause lat with db params right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left right) +innerJoin = inner . Join + +{- | +Like `innerJoin` with a `subquery` but allowed to reference columns provided +by preceding `FromClause` items. +-} +innerJoinLateral + :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery + -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left '[query]) +innerJoinLateral = inner . JoinLateral + +{- | @left & leftOuter (Join right) on@. First, an inner join is performed. +Then, for each row in @left@ that does not satisfy the @on@ condition with +any row in @right@, a joined row is added with null values in columns of @right@. +Thus, the joined table always has at least one row for each row in @left@. +-} +leftOuter + :: JoinItem lat with db params left right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left (NullifyFrom right)) +leftOuter item on tab = UnsafeFromClause $ + renderSQL tab <+> "LEFT OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on + +{- | @left & leftOuterJoin right on@. First, an inner join is performed. +Then, for each row in @left@ that does not satisfy the @on@ condition with +any row in @right@, a joined row is added with null values in columns of @right@. +Thus, the joined table always has at least one row for each row in @left@. +-} +leftOuterJoin + :: FromClause lat with db params right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left (NullifyFrom right)) +leftOuterJoin = leftOuter . Join + +{- | +Like `leftOuterJoin` with a `subquery` but allowed to reference columns provided +by preceding `FromClause` items. +-} +leftOuterJoinLateral + :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery + -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join left (NullifyFrom '[query])) +leftOuterJoinLateral = leftOuter . JoinLateral + +{- | @left & rightOuter (Join right) on@. First, an inner join is performed. +Then, for each row in @right@ that does not satisfy the @on@ condition with +any row in @left@, a joined row is added with null values in columns of @left@. +This is the converse of a left join: the result table will always +have a row for each row in @right@. +-} +rightOuter + :: JoinItem lat with db params left right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join (NullifyFrom left) right) +rightOuter item on tab = UnsafeFromClause $ + renderSQL tab <+> "RIGHT OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on + +{- | @left & rightOuterJoin right on@. First, an inner join is performed. +Then, for each row in @right@ that does not satisfy the @on@ condition with +any row in @left@, a joined row is added with null values in columns of @left@. +This is the converse of a left join: the result table will always +have a row for each row in @right@. +-} +rightOuterJoin + :: FromClause lat with db params right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join (NullifyFrom left) right) +rightOuterJoin = rightOuter . Join + +{- | +Like `rightOuterJoin` with a `subquery` but allowed to reference columns provided +by preceding `FromClause` items. +-} +rightOuterJoinLateral + :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery + -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (Join (NullifyFrom left) '[query]) +rightOuterJoinLateral = rightOuter . JoinLateral + +{- | @left & fullOuter (Join right) on@. First, an inner join is performed. +Then, for each row in @left@ that does not satisfy the @on@ condition with +any row in @right@, a joined row is added with null values in columns of @right@. +Also, for each row of @right@ that does not satisfy the join condition +with any row in @left@, a joined row with null values in the columns of @left@ +is added. +-} +fullOuter + :: JoinItem lat with db params left right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (NullifyFrom (Join left right)) +fullOuter item on tab = UnsafeFromClause $ + renderSQL tab <+> "FULL OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on + +{- | @left & fullOuterJoin right on@. First, an inner join is performed. +Then, for each row in @left@ that does not satisfy the @on@ condition with +any row in @right@, a joined row is added with null values in columns of @right@. +Also, for each row of @right@ that does not satisfy the join condition +with any row in @left@, a joined row with null values in the columns of @left@ +is added. +-} +fullOuterJoin + :: FromClause lat with db params right -- ^ right + -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (NullifyFrom (Join left right)) +fullOuterJoin = fullOuter . Join + +{- | +Like `fullOuterJoin` with a `subquery` but allowed to reference columns provided +by preceding `FromClause` items. +-} +fullOuterJoinLateral + :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery + -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition + -> FromClause lat with db params left -- ^ left + -> FromClause lat with db params (NullifyFrom (Join left '[query])) +fullOuterJoinLateral = fullOuter . JoinLateral diff --git a/src/Squeal/PostgreSQL/Query/From/Set.hs b/src/Squeal/PostgreSQL/Query/From/Set.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/From/Set.hs @@ -0,0 +1,205 @@ +{-| +Module: Squeal.PostgreSQL.Query.From.Set +Description: set returning functions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +set returning functions +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.From.Set + ( -- * Set Functions + type (-|->) + , type (--|->) + , SetFun + , SetFunN + , generateSeries + , generateSeriesStep + , generateSeriesTimestamp + , unsafeSetFunction + , setFunction + , unsafeSetFunctionN + , setFunctionN + ) where + +import Data.ByteString (ByteString) +import Generics.SOP hiding (from) +import GHC.TypeLits + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Query.From +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema + +{- | +A @RankNType@ for set returning functions with 1 argument. +-} +type (-|->) arg set = forall db. SetFun db arg set + +{- | +A @RankNType@ for set returning functions with multiple argument. +-} +type (--|->) arg set = forall db. SetFunN db arg set + -- ^ output + +{- | +Like `-|->` but depends on the schemas of the database +-} +type SetFun db arg row + = forall lat with params + . Expression 'Ungrouped lat with db params '[] arg + -- ^ input + -> FromClause lat with db params '[row] + -- ^ output + +{- | +Like `--|->` but depends on the schemas of the database +-} +type SetFunN db args set + = forall lat with params + . NP (Expression 'Ungrouped lat with db params '[]) args + -- ^ input + -> FromClause lat with db params '[set] + -- ^ output + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | Escape hatch for a set returning function of a single variable +unsafeSetFunction + :: forall fun ty row. KnownSymbol fun + => ByteString + -> ty -|-> (fun ::: row) -- ^ set returning function +unsafeSetFunction fun x = UnsafeFromClause $ + fun <> parenthesized (renderSQL x) + +{- | Call a user defined set returning function of a single variable + +>>> type Fn = '[ 'Null 'PGbool] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric] +>>> type Schema = '["fn" ::: 'Function Fn] +>>> :{ +let + fn :: SetFun (Public Schema) ('Null 'PGbool) ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric]) + fn = setFunction #fn +in + printSQL (fn true) +:} +"fn"(TRUE) +-} +setFunction + :: ( Has sch db schema + , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) ) + => QualifiedAlias sch fun -- ^ function alias + -> SetFun db ty (fun ::: row) +setFunction fun = unsafeSetFunction (renderSQL fun) + +{- | Escape hatch for a multivariable set returning function-} +unsafeSetFunctionN + :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun) + => ByteString + -> tys --|-> (fun ::: row) -- ^ set returning function +unsafeSetFunctionN fun xs = UnsafeFromClause $ + fun <> parenthesized (renderCommaSeparated renderSQL xs) + +{- | Call a user defined multivariable set returning function + +>>> type Fn = '[ 'Null 'PGbool, 'Null 'PGtext] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric] +>>> type Schema = '["fn" ::: 'Function Fn] +>>> :{ +let + fn :: SetFunN (Public Schema) + '[ 'Null 'PGbool, 'Null 'PGtext] + ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric]) + fn = setFunctionN #fn +in + printSQL (fn (true *: "hi")) +:} +"fn"(TRUE, (E'hi' :: text)) +-} +setFunctionN + :: ( Has sch db schema + , Has fun schema ('Function (tys :=> 'ReturnsTable row)) + , SOP.SListI tys ) + => QualifiedAlias sch fun -- ^ function alias + -> SetFunN db tys (fun ::: row) +setFunctionN fun = unsafeSetFunctionN (renderSQL fun) + +{- | @generateSeries (start :* stop)@ + +Generate a series of values, +from @start@ to @stop@ with a step size of one + +>>> printSQL (generateSeries @'PGint4 (1 *: 10)) +generate_series((1 :: int4), (10 :: int4)) +-} +generateSeries + :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] + => '[ null ty, null ty] --|-> + ("generate_series" ::: '["generate_series" ::: null ty]) + -- ^ set returning function +generateSeries = unsafeSetFunctionN "generate_series" + +{- | @generateSeriesStep (start :* stop *: step)@ + +Generate a series of values, +from @start@ to @stop@ with a step size of @step@ + +>>> printSQL (generateSeriesStep @'PGint8 (2 :* 100 *: 2)) +generate_series((2 :: int8), (100 :: int8), (2 :: int8)) +-} +generateSeriesStep + :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] + => '[null ty, null ty, null ty] --|-> + ("generate_series" ::: '["generate_series" ::: null ty]) + -- ^ set returning function +generateSeriesStep = unsafeSetFunctionN "generate_series" + +{- | @generateSeriesTimestamp (start :* stop *: step)@ + +Generate a series of timestamps, +from @start@ to @stop@ with a step size of @step@ + +>>> :{ +let + start = now + stop = now !+ interval_ 10 Years + step = interval_ 1 Months +in printSQL (generateSeriesTimestamp (start :* stop *: step)) +:} +generate_series(now(), (now() + (INTERVAL '10.000 years')), (INTERVAL '1.000 months')) +-} +generateSeriesTimestamp + :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz] + => '[null ty, null ty, null 'PGinterval] --|-> + ("generate_series" ::: '["generate_series" ::: null ty]) + -- ^ set returning function +generateSeriesTimestamp = unsafeSetFunctionN "generate_series" diff --git a/src/Squeal/PostgreSQL/Query/Select.hs b/src/Squeal/PostgreSQL/Query/Select.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/Select.hs @@ -0,0 +1,253 @@ +{-| +Module: Squeal.PostgreSQL.Query.Select +Description: select statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +select statements +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.Select + ( -- ** Select + select + , select_ + , selectDistinct + , selectDistinct_ + , selectDistinctOn + , selectDistinctOn_ + , Selection (..) + ) where + +import Data.ByteString (ByteString) +import Data.String +import Generics.SOP hiding (from) +import GHC.TypeLits + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Expression.Sort +import Squeal.PostgreSQL.Expression.Window +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Query.Table +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{----------------------------------------- +SELECT queries +-----------------------------------------} + +{- | The simplest kinds of `Selection` are `Star` and `DotStar` which +emits all columns that a `TableExpression` produces. A select `List` +is a list of `Expression`s. A `Selection` could be a list of +`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can +be selected with `Also`. +-} +data Selection grp lat with db params from row where + Star + :: HasUnique tab from row + => Selection 'Ungrouped lat with db params from row + -- ^ `HasUnique` table in the `Squeal.PostgreSQL.Query.From.FromClause` + DotStar + :: Has tab from row + => Alias tab + -- ^ `Has` table with `Alias` + -> Selection 'Ungrouped lat with db params from row + List + :: SListI row + => NP (Aliased (Expression grp lat with db params from)) row + -- ^ `NP` list of `Aliased` `Expression`s + -> Selection grp lat with db params from row + Over + :: SListI row + => NP (Aliased (WindowFunction grp lat with db params from)) row + -- ^ `NP` list of `Aliased` `WindowFunction`s + -> WindowDefinition grp lat with db params from + -> Selection grp lat with db params from row + Also + :: Selection grp lat with db params from right + -- ^ `Additional` `Selection` + -> Selection grp lat with db params from left + -> Selection grp lat with db params from (Join left right) +instance Additional (Selection grp lat with db params from) where + also = Also +instance (KnownSymbol col, row ~ '[col ::: ty]) + => Aliasable col + (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 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 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 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 from lat) row0 + , Has col row0 ty + , row1 ~ '[col ::: ty] + , GroupedBy tab col bys ) + => IsLabel col + (Selection ('Grouped bys) lat with db params from row1) where + fromLabel = fromLabel @col `as` Alias + +instance RenderSQL (Selection grp lat with db params from row) where + renderSQL = \case + List list -> renderCommaSeparated (renderAliased renderSQL) list + Star -> "*" + DotStar tab -> renderSQL tab <> ".*" + Also right left -> renderSQL left <> ", " <> renderSQL right + Over winFns winDef -> + let + renderOver + :: Aliased (WindowFunction grp lat with db params from) field + -> ByteString + renderOver (winFn `As` col) = renderSQL winFn + <+> "OVER" <+> parenthesized (renderSQL winDef) + <+> "AS" <+> renderSQL col + in + renderCommaSeparated renderOver winFns + +instance IsString + (Selection grp lat with db params from '["fromOnly" ::: 'NotNull 'PGtext]) where + fromString str = fromString str `as` Alias + +-- | the `TableExpression` in the `select` command constructs an intermediate +-- virtual table by possibly combining tables, views, eliminating rows, +-- grouping, etc. This table is finally passed on to processing by +-- the select list. The `Selection` determines which columns of +-- the intermediate table are actually output. +select + :: (SListI row, row ~ (x ': xs)) + => Selection grp lat with db params from row + -- ^ selection + -> TableExpression grp lat with db params from + -- ^ intermediate virtual table + -> Query lat with db params row +select selection tabexpr = UnsafeQuery $ + "SELECT" + <+> renderSQL selection + <+> renderSQL tabexpr + +-- | Like `select` but takes an `NP` list of `Expression`s instead +-- of a general `Selection`. +select_ + :: (SListI row, row ~ (x ': xs)) + => NP (Aliased (Expression grp lat with db params from)) row + -- ^ select list + -> TableExpression grp lat with db params from + -- ^ intermediate virtual table + -> Query lat with db params row +select_ = select . List + +-- | After the select list has been processed, the result table can +-- be subject to the elimination of duplicate rows using `selectDistinct`. +selectDistinct + :: (SListI columns, columns ~ (col ': cols)) + => Selection grp lat with db params from columns + -- ^ selection + -> TableExpression grp lat with db params from + -- ^ intermediate virtual table + -> Query lat with db params columns +selectDistinct selection tabexpr = UnsafeQuery $ + "SELECT DISTINCT" + <+> renderSQL selection + <+> renderSQL tabexpr + +-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead +-- of a general `Selection`. +selectDistinct_ + :: (SListI columns, columns ~ (col ': cols)) + => NP (Aliased (Expression grp lat with db params from)) columns + -- ^ select list + -> TableExpression grp lat with db params from + -- ^ intermediate virtual table + -> Query lat with db params columns +selectDistinct_ = selectDistinct . List + +{-| +`selectDistinctOn` keeps only the first row of each set of rows where +the given expressions evaluate to equal. The DISTINCT ON expressions are +interpreted using the same rules as for ORDER BY. ORDER BY is used to +ensure that the desired row appears first. + +The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s). +The ORDER BY clause will normally contain additional expression(s) that +determine the desired precedence of rows within each DISTINCT ON group. + +In order to guarantee they match and reduce redundancy, this function +will prepend the The DISTINCT ON expressions to the ORDER BY clause. +-} +selectDistinctOn + :: (SListI columns, columns ~ (col ': cols)) + => [SortExpression grp lat with db params from] + -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause + -> Selection grp lat with db params from columns + -- ^ selection + -> TableExpression grp lat with db params from + -- ^ intermediate virtual table + -> Query lat with db params columns +selectDistinctOn distincts selection tab = UnsafeQuery $ + "SELECT DISTINCT ON" + <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts)) + <+> renderSQL selection + <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab}) + where + renderDistinctOn = \case + Asc expression -> renderSQL expression + Desc expression -> renderSQL expression + AscNullsFirst expression -> renderSQL expression + DescNullsFirst expression -> renderSQL expression + AscNullsLast expression -> renderSQL expression + DescNullsLast expression -> renderSQL expression + +-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead +-- of a general `Selection`. +selectDistinctOn_ + :: (SListI columns, columns ~ (col ': cols)) + => [SortExpression grp lat with db params from] + -- ^ distinct on and return the first row in ordering + -> NP (Aliased (Expression grp lat with db params from)) columns + -- ^ selection + -> TableExpression grp lat with db params from + -- ^ intermediate virtual table + -> Query lat with db params columns +selectDistinctOn_ distincts = selectDistinctOn distincts . List diff --git a/src/Squeal/PostgreSQL/Query/Table.hs b/src/Squeal/PostgreSQL/Query/Table.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/Table.hs @@ -0,0 +1,410 @@ +{-| +Module: Squeal.PostgreSQL.Query.Table +Description: intermediate table expressions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +intermediate table expressions +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.Table + ( -- * Table Expression + TableExpression (..) + , from + , where_ + , groupBy + , having + , limit + , offset + , lockRows + -- * Grouping + , By (..) + , GroupByClause (..) + , HavingClause (..) + -- * Row Locks + , LockingClause (..) + , LockStrength (..) + , Waiting (..) + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) +import Data.String +import Data.Word +import Generics.SOP hiding (from) +import GHC.TypeLits + +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression.Logic +import Squeal.PostgreSQL.Expression.Sort +import Squeal.PostgreSQL.Query.From +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +{----------------------------------------- +Table Expressions +-----------------------------------------} + +-- | A `TableExpression` computes a table. The table expression contains +-- a `fromClause` that is optionally followed by a `whereClause`, +-- `groupByClause`, `havingClause`, `orderByClause`, `limitClause` +-- `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 + (grp :: Grouping) + (lat :: FromType) + (with :: FromType) + (db :: SchemasType) + (params :: [NullType]) + (from :: FromType) + = TableExpression + { fromClause :: FromClause lat with db params from + -- ^ A table reference that can be a table name, or a derived table such + -- as a subquery, a @JOIN@ construct, or complex combinations of these. + , whereClause :: [Condition 'Ungrouped lat with db params from] + -- ^ optional search coditions, combined with `.&&`. After the processing + -- of the `fromClause` is done, each row of the derived virtual table + -- is checked against the search condition. If the result of the + -- condition is true, the row is kept in the output table, + -- otherwise it is discarded. The search condition typically references + -- at least one column of the table generated in the `fromClause`; + -- this is not required, but otherwise the WHERE clause will + -- be fairly useless. + , groupByClause :: GroupByClause grp from + -- ^ The `groupByClause` is used to group together those rows in a table + -- that have the same values in all the columns listed. The order in which + -- the columns are listed does not matter. The effect is to combine each + -- set of rows having common values into one group row that represents all + -- rows in the group. This is done to eliminate redundancy in the output + -- and/or compute aggregates that apply to these groups. + , havingClause :: HavingClause grp lat with db params from + -- ^ If a table has been grouped using `groupBy`, but only certain groups + -- are of interest, the `havingClause` can be used, much like a + -- `whereClause`, to eliminate groups from the result. Expressions in the + -- `havingClause` can refer both to grouped expressions and to ungrouped + -- expressions (which necessarily involve an aggregate function). + , orderByClause :: [SortExpression grp lat with db params from] + -- ^ The `orderByClause` is for optional sorting. When more than one + -- `SortExpression` is specified, the later (right) values are used to sort + -- rows that are equal according to the earlier (left) values. + , limitClause :: [Word64] + -- ^ The `limitClause` is combined with `min` to give a limit count + -- if nonempty. If a limit count is given, no more than that many rows + -- will be returned (but possibly fewer, if the query itself yields + -- fewer rows). + , offsetClause :: [Word64] + -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count + -- 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' lks') = mconcat + [ "FROM ", renderSQL frm' + , renderWheres whs' + , renderSQL grps' + , renderSQL hvs' + , renderSQL srts' + , renderLimits lims' + , renderOffsets offs' + , renderLocks lks' ] + where + renderWheres = \case + [] -> "" + wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs) + renderLimits = \case + [] -> "" + lims -> " LIMIT" <+> fromString (show (minimum lims)) + 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, +-- or complex combinations of these. A `from` may be transformed by `where_`, +-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, +-- using the `Data.Function.&` operator +-- to match the left-to-right sequencing of their placement in SQL. +from + :: FromClause lat with db params from -- ^ table reference + -> TableExpression 'Ungrouped lat with db params from +from tab = TableExpression tab [] noGroups NoHaving [] [] [] [] + +-- | A `where_` is an endomorphism of `TableExpression`s which adds a +-- search condition to the `whereClause`. +where_ + :: Condition 'Ungrouped lat with db params from -- ^ filtering condition + -> TableExpression grp lat with db params from + -> TableExpression grp lat with db params from +where_ wh rels = rels {whereClause = wh : whereClause rels} + +-- | A `groupBy` is a transformation of `TableExpression`s which switches +-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform +-- a "grand total" aggregation query. +groupBy + :: SListI bys + => NP (By from) bys -- ^ grouped columns + -> TableExpression 'Ungrouped lat with db params from + -> TableExpression ('Grouped bys) lat with db params from +groupBy bys rels = TableExpression + { fromClause = fromClause rels + , whereClause = whereClause rels + , groupByClause = group bys + , havingClause = Having [] + , orderByClause = [] + , limitClause = limitClause rels + , offsetClause = offsetClause rels + , lockingClauses = lockingClauses rels + } + +-- | A `having` is an endomorphism of `TableExpression`s which adds a +-- search condition to the `havingClause`. +having + :: Condition ('Grouped bys) lat with db params from -- ^ having condition + -> TableExpression ('Grouped bys) lat with db params from + -> TableExpression ('Grouped bys) lat with db params from +having hv rels = rels + { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) } + +instance OrderBy (TableExpression grp) grp where + orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts} + +-- | A `limit` is an endomorphism of `TableExpression`s which adds to the +-- `limitClause`. +limit + :: Word64 -- ^ limit parameter + -> TableExpression grp lat with db params from + -> TableExpression grp lat with db params from +limit lim rels = rels {limitClause = lim : limitClause rels} + +-- | An `offset` is an endomorphism of `TableExpression`s which adds to the +-- `offsetClause`. +offset + :: Word64 -- ^ offset parameter + -> TableExpression grp lat with db params from + -> 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. +Further, a `LockingClause` cannot be added to a grouped table expression. +-} +lockRows + :: LockingClause from -- ^ row-level lock + -> TableExpression 'Ungrouped lat with db params from + -> TableExpression 'Ungrouped lat with db params from +lockRows lck tab = tab {lockingClauses = lck : lockingClauses tab} + +{----------------------------------------- +Grouping +-----------------------------------------} + +-- | `By`s are used in `groupBy` to reference a list of columns which are then +-- used to group together those rows in a table that have the same values +-- in all the columns listed. @By \#col@ will reference an unambiguous +-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table +-- qualified column @tab.col@. +data By + (from :: FromType) + (by :: (Symbol,Symbol)) where + By1 + :: (HasUnique table from columns, Has column columns ty) + => Alias column + -> By from '(table, column) + By2 + :: (Has table from columns, Has column columns ty) + => Alias table + -> Alias column + -> By from '(table, column) +deriving instance Show (By from by) +deriving instance Eq (By from by) +deriving instance Ord (By from by) +instance RenderSQL (By from by) where + renderSQL = \case + By1 column -> renderSQL column + By2 rel column -> renderSQL rel <> "." <> renderSQL column + +instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col)) + => IsLabel col (By rels by) where fromLabel = By1 fromLabel +instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)]) + => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil +instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col)) + => IsQualified rel col (By rels by) where (!) = By2 +instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)]) + => IsQualified rel col (NP (By rels) bys) where + rel ! col = By2 rel col :* Nil + +-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`. +newtype GroupByClause grp from = UnsafeGroupByClause + { renderGroupByClause :: ByteString } + deriving stock (GHC.Generic,Show,Eq,Ord) + deriving newtype (NFData) +instance RenderSQL (GroupByClause grp from) where + renderSQL = renderGroupByClause +noGroups :: GroupByClause 'Ungrouped from +noGroups = UnsafeGroupByClause "" +group + :: SListI bys + => NP (By from) bys + -> GroupByClause ('Grouped bys) from +group bys = UnsafeGroupByClause $ case bys of + Nil -> "" + _ -> " GROUP BY" <+> renderCommaSeparated renderSQL bys + +-- | A `HavingClause` is used to eliminate groups that are not of interest. +-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped` +-- `TableExpression` must use `Having` whose conditions are combined with +-- `.&&`. +data HavingClause grp lat with db params from where + NoHaving :: HavingClause 'Ungrouped lat with db params from + Having + :: [Condition ('Grouped bys) lat with db params from] + -> HavingClause ('Grouped bys) lat with db params from +deriving instance Show (HavingClause grp lat with db params from) +deriving instance Eq (HavingClause grp lat with db params from) +deriving instance Ord (HavingClause grp lat with db params from) + +-- | Render a `HavingClause`. +instance RenderSQL (HavingClause grp lat with db params from) where + renderSQL = \case + NoHaving -> "" + 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/Values.hs b/src/Squeal/PostgreSQL/Query/Values.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/Values.hs @@ -0,0 +1,89 @@ +{-| +Module: Squeal.PostgreSQL.Query.Values +Description: values statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +values statements +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.Values + ( -- ** Values + values + , values_ + ) where + +import Data.ByteString (ByteString) +import Generics.SOP hiding (from) + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Render + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | `values` computes a row value or set of row values +-- specified by value expressions. It is most commonly used +-- to generate a “constant table” within a larger command, +-- but it can be used on its own. +-- +-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext] +-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query lat with db '[] Row +-- >>> printSQL query +-- SELECT * FROM (VALUES ((1 :: int4), (E'one' :: text))) AS t ("a", "b") +values + :: SListI cols + => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols + -> [NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols] + -- ^ When more than one row is specified, all the rows must + -- must have the same number of elements + -> Query lat with db params cols +values rw rws = UnsafeQuery $ "SELECT * FROM" + <+> parenthesized ( + "VALUES" + <+> commaSeparated + ( parenthesized + . renderCommaSeparated renderValuePart <$> rw:rws ) + ) <+> "AS t" + <+> parenthesized (renderCommaSeparated renderAliasPart rw) + where + renderAliasPart, renderValuePart + :: Aliased (Expression 'Ungrouped lat with db params '[] ) ty -> ByteString + renderAliasPart (_ `As` name) = renderSQL name + renderValuePart (value `As` _) = renderSQL value + +-- | `values_` computes a row value or set of row values +-- specified by value expressions. +values_ + :: SListI cols + => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols + -- ^ one row of values + -> Query lat with db params cols +values_ rw = values rw [] diff --git a/src/Squeal/PostgreSQL/Query/With.hs b/src/Squeal/PostgreSQL/Query/With.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Query/With.hs @@ -0,0 +1,246 @@ +{-| +Module: Squeal.PostgreSQL.Query.With +Description: with statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +with statements +-} + +{-# LANGUAGE + ConstraintKinds + , DeriveGeneric + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , QuantifiedConstraints + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , RankNTypes + , UndecidableInstances + #-} + +module Squeal.PostgreSQL.Query.With + ( -- ** With + With (..) + , CommonTableExpression (..) + , withRecursive + , Materialization (..) + , materialized + , notMaterialized + ) where + +import Data.Quiver.Functor +import GHC.TypeLits + +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Type.Schema + +-- $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` 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 + -- ^ common table expressions + -> statement with1 db params row + -- ^ larger query + -> statement with0 db params row +instance With (Query lat) where + with Done query = query + 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 + 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 + -- ^ recursive query + -> Query lat (recursive ': with) db params row + -- ^ larger query + -> Query lat with db params row +withRecursive (recursive `As` cte) query = UnsafeQuery $ + "WITH RECURSIVE" <+> renderSQL cte + <+> "AS" <+> parenthesized (renderSQL recursive) + <+> renderSQL query + +-- | Whether the contents of the WITH clause are materialized. +-- If a WITH query is non-recursive and side-effect-free (that is, it is a SELECT containing no volatile functions) then it can be folded into the parent query, allowing joint optimization of the two query levels. +-- +-- Note: Use of `Materialized` or `NotMaterialized` requires PostgreSQL version 12 or higher. For earlier versions, use `DefaultMaterialization` which in those earlier versions of PostgreSQL behaves as `Materialized`. PostgreSQL 12 both changes the default behavior as well as adds options for customizing the materialization behavior. +data Materialization = + DefaultMaterialization -- ^ By default, folding happens if the parent query references the WITH query just once, but not if it references the WITH query more than once. Note: this is the behavior in PostgreSQL 12+. In PostgreSQL 11 and earlier, all CTEs are materialized. + | Materialized -- ^ You can override that decision by specifying MATERIALIZED to force separate calculation of the WITH query. Requires PostgreSQL 12+. + | NotMaterialized -- ^ or by specifying NOT MATERIALIZED to force it to be merged into the parent query. Requires PostgreSQL 12+. + deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) +instance SOP.Generic Materialization +instance SOP.HasDatatypeInfo Materialization +instance RenderSQL Materialization where + renderSQL = \case + DefaultMaterialization -> "" + Materialized -> "MATERIALIZED" + NotMaterialized -> "NOT MATERIALIZED" + +-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause. +data CommonTableExpression statement + (db :: SchemasType) + (params :: [NullType]) + (with0 :: FromType) + (with1 :: FromType) where + CommonTableExpression + :: Aliased (statement with db params) (cte ::: common) + -- ^ aliased statement + -> Materialization + -- ^ materialization of the CTE output + -> CommonTableExpression statement db params with (cte ::: common ': with) +instance + ( KnownSymbol cte + , with1 ~ (cte ::: common ': with) + ) => Aliasable cte + (statement with db params common) + (CommonTableExpression statement db params with with1) where + statement `as` cte = CommonTableExpression (statement `as` cte) DefaultMaterialization +instance + ( KnownSymbol cte + , with1 ~ (cte ::: common ': with) + ) => Aliasable cte + (statement with db params common) + (Path (CommonTableExpression statement db params) with with1) where + statement `as` cte = qsingle (statement `as` cte) + +instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL + (CommonTableExpression statement db params with0 with1) where + renderSQL (CommonTableExpression (statement `As` cte) materialization) = + renderSQL cte + <+> "AS" + <+> renderSQL materialization + <> case materialization of + DefaultMaterialization -> "" + _ -> " " + <> parenthesized (renderSQL statement) + +{- | Force separate calculation of the WITH query. + +>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = with ( + materialized (select Star (from (table #tab)) `as` #cte1) :>> + select Star (from (common #cte1)) `as` #cte2 + ) (select Star (from (common #cte2))) +in printSQL qry +:} +WITH "cte1" AS MATERIALIZED (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" + +Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done`. + +Requires PostgreSQL 12 or higher. +-} +materialized + :: Aliased (statement with db params) (cte ::: common) -- ^ CTE + -> CommonTableExpression statement db params with (cte ::: common ': with) +materialized stmt = CommonTableExpression stmt Materialized + +{- | Force the WITH query to be merged into the parent query. + +>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> :{ +let + qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] + qry = with ( + select Star (from (table #tab)) `as` #cte1 :>> + notMaterialized (select Star (from (common #cte1)) `as` #cte2) :>> + Done + ) (select Star (from (common #cte2))) +in printSQL qry +:} +WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS NOT MATERIALIZED (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" + +Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done` to finish the `Path`. + +Requires PostgreSQL 12 or higher. +-} +notMaterialized + :: Aliased (statement with db params) (cte ::: common) -- ^ CTE + -> CommonTableExpression statement db params with (cte ::: common ': with) +notMaterialized stmt = CommonTableExpression stmt NotMaterialized diff --git a/src/Squeal/PostgreSQL/Render.hs b/src/Squeal/PostgreSQL/Render.hs --- a/src/Squeal/PostgreSQL/Render.hs +++ b/src/Squeal/PostgreSQL/Render.hs @@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Render -Description: Rendering helper functions -Copyright: (c) Eitan Chatav, 2017 +Description: render functions +Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Rendering helper functions. +render functions -} {-# LANGUAGE @@ -33,6 +33,8 @@ , doubleQuoted , singleQuotedText , singleQuotedUtf8 + , escapeQuotedString + , escapeQuotedText , renderCommaSeparated , renderCommaSeparatedConstraint , renderCommaSeparatedMaybe @@ -43,7 +45,6 @@ import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString) import Data.Maybe (catMaybes) -import Data.Monoid ((<>)) import Data.Text (Text) import Generics.SOP import GHC.Exts @@ -84,6 +85,15 @@ singleQuotedUtf8 :: ByteString -> ByteString singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8 +-- | Escape quote a string. +escapeQuotedString :: String -> ByteString +escapeQuotedString x = "E\'" <> Text.encodeUtf8 (fromString (escape =<< x)) <> "\'" + +-- | Escape quote a string. +escapeQuotedText :: Text -> ByteString +escapeQuotedText x = + "E\'" <> Text.encodeUtf8 (Text.concatMap (fromString . escape) x) <> "\'" + -- | Comma separate the renderings of a heterogeneous list. renderCommaSeparated :: SListI xs @@ -134,7 +144,7 @@ -- | `escape` a character to prevent injection escape :: Char -> String escape = \case - '\NUL' -> "\\0" + '\NUL' -> "" '\'' -> "''" '"' -> "\\\"" '\b' -> "\\b" diff --git a/src/Squeal/PostgreSQL/Schema.hs b/src/Squeal/PostgreSQL/Schema.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Schema.hs +++ /dev/null @@ -1,449 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Schema -Description: Embedding of PostgreSQL type and alias system -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types, -tables, schema, constraints, aliases, enumerated labels, and groupings. -It also defines useful type families to operate on these. Finally, -it defines an embedding of Haskell types into Postgres types. --} -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , OverloadedStrings - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilyDependencies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Schema - ( -- * Postgres Types - PGType (..) - , NullityType (..) - , RowType - , FromType - -- * Schema Types - , ColumnType - , ColumnsType - , TableType - , SchemumType (..) - , SchemaType - , SchemasType - , Public - -- * Constraints - , (:=>) - , ColumnConstraint (..) - , TableConstraint (..) - , TableConstraints - , Uniquely - -- * Enumerated Labels - , IsPGlabel (..) - , PGlabel (..) - -- * Data Definitions - , Create - , Drop - , Alter - , Rename - , ConstraintInvolves - , DropIfConstraintsInvolve - , IsNotElem - , AllUnique - -- * Type Classifications - , PGNum - , PGIntegral - , PGFloating - , PGTypeOf - , PGJsonType - , PGJsonKey - , SamePGType - , AllNotNull - , NotAllNull - -- * Nullifications - , NullifyType - , NullifyRow - , NullifyFrom - -- * Table Conversions - , TableToColumns - , ColumnsToRow - , TableToRow - ) where - -import Control.Category -import Data.Kind -import Data.Monoid hiding (All) -import Data.Type.Bool -import Generics.SOP -import GHC.TypeLits -import Prelude hiding (id, (.)) - -import Squeal.PostgreSQL.Alias -import Squeal.PostgreSQL.List -import Squeal.PostgreSQL.Render - --- $setup --- >>> import Squeal.PostgreSQL - --- | `PGType` is the promoted datakind of PostgreSQL types. --- --- >>> :kind 'PGbool --- 'PGbool :: PGType -data PGType - = PGbool -- ^ logical Boolean (true/false) - | PGint2 -- ^ signed two-byte integer - | PGint4 -- ^ signed four-byte integer - | PGint8 -- ^ signed eight-byte integer - | PGnumeric -- ^ arbitrary precision numeric type - | PGfloat4 -- ^ single precision floating-point number (4 bytes) - | PGfloat8 -- ^ double precision floating-point number (8 bytes) - | PGmoney -- ^ currency amount - | PGchar Nat -- ^ fixed-length character string - | PGvarchar Nat -- ^ variable-length character string - | PGtext -- ^ variable-length character string - | PGbytea -- ^ binary data ("byte array") - | PGtimestamp -- ^ date and time (no time zone) - | PGtimestamptz -- ^ date and time, including time zone - | PGdate -- ^ calendar date (year, month, day) - | PGtime -- ^ time of day (no time zone) - | PGtimetz -- ^ time of day, including time zone - | PGinterval -- ^ time span - | PGuuid -- ^ universally unique identifier - | PGinet -- ^ IPv4 or IPv6 host address - | PGjson -- ^ textual JSON data - | PGjsonb -- ^ binary JSON data, decomposed - | PGvararray NullityType -- ^ variable length array - | PGfixarray [Nat] NullityType -- ^ fixed length array - | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values. - | 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 - | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types - --- | `NullityType` encodes the potential presence or definite absence of a --- @NULL@ allowing operations which are sensitive to such to be well typed. --- --- >>> :kind 'Null 'PGint4 --- 'Null 'PGint4 :: NullityType --- >>> :kind 'NotNull ('PGvarchar 50) --- 'NotNull ('PGvarchar 50) :: NullityType -data NullityType - = Null PGType -- ^ @NULL@ may be present - | NotNull PGType -- ^ @NULL@ is absent - --- | The constraint operator, `:=>` is a type level pair --- between a "constraint" and some type, for use in pairing --- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType` --- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`. -type (:=>) constraint ty = '(constraint,ty) -infixr 7 :=> - --- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates. --- A column can be assigned a default value. --- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also --- request explicitly that a column be set to its default value, --- without having to know what that value is. -data ColumnConstraint - = Def -- ^ @DEFAULT@ is available for inserts and updates - | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates - --- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the --- base `PGType` for a column. --- --- >>> :set -XTypeFamilies -XTypeInType --- >>> import GHC.TypeLits --- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4 --- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext -type ColumnType = (ColumnConstraint,NullityType) - --- | `ColumnsType` is a row of `ColumnType`s. --- --- >>> :{ --- type family UsersColumns :: ColumnsType where --- UsersColumns = --- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext --- , "id" ::: 'Def :=> 'NotNull 'PGint4 --- ] --- :} -type ColumnsType = [(Symbol,ColumnType)] - --- | `TableConstraint` encodes various forms of data constraints --- of columns in a table. --- `TableConstraint`s give you as much control over the data in your tables --- as you wish. If a user attempts to store data in a column that would --- violate a constraint, an error is raised. This applies --- even if the value came from the default value definition. -data TableConstraint - = Check [Symbol] - | Unique [Symbol] - | PrimaryKey [Symbol] - | ForeignKey [Symbol] Symbol [Symbol] - -{- | A `TableConstraints` is a row of `TableConstraint`s. - ->>> :{ -type family UsersConstraints :: TableConstraints where - UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] -:} --} -type TableConstraints = [(Symbol,TableConstraint)] - --- | A `ForeignKey` must reference columns that either are --- a `PrimaryKey` or form a `Unique` constraint. -type family Uniquely - (key :: [Symbol]) - (constraints :: TableConstraints) :: Constraint where - Uniquely key (uq ::: 'Unique key ': constraints) = () - Uniquely key (pk ::: 'PrimaryKey key ': constraints) = () - Uniquely key (_ ': constraints) = Uniquely key constraints - --- | `TableType` encodes a row of constraints on a table as well as the types --- of its columns. --- --- >>> :{ --- type family UsersTable :: TableType where --- UsersTable = --- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ] --- :} -type TableType = (TableConstraints,ColumnsType) - -{- | A `RowType` is a row of `NullityType`. They correspond to Haskell -record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places. - ->>> :{ -type family PersonRow :: RowType where - PersonRow = - '[ "name" ::: 'NotNull 'PGtext - , "age" ::: 'NotNull 'PGint4 - , "dateOfBirth" ::: 'Null 'PGdate - ] -:} --} -type RowType = [(Symbol,NullityType)] - -{- | `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. --} -type FromType = [(Symbol,RowType)] - --- | `ColumnsToRow` removes column constraints. -type family ColumnsToRow (columns :: ColumnsType) :: RowType where - ColumnsToRow '[] = '[] - ColumnsToRow (column ::: constraint :=> ty ': columns) = - column ::: ty ': ColumnsToRow columns - --- | `TableToColumns` removes table constraints. -type family TableToColumns (table :: TableType) :: ColumnsType where - TableToColumns (constraints :=> columns) = columns - --- | Convert a table to a row type. -type family TableToRow (table :: TableType) :: RowType where - TableToRow tab = ColumnsToRow (TableToColumns tab) - --- | Numeric Postgres types. -type PGNum = - '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8] - --- | Floating Postgres types. -type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric] - --- | Integral Postgres types. -type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8] - --- | `PGTypeOf` forgets about @NULL@ and any column constraints. -type family PGTypeOf (ty :: NullityType) :: PGType where - PGTypeOf (nullity pg) = pg - --- | Equality constraint on the underlying `PGType` of two columns. -class SamePGType - (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where -instance ty0 ~ ty1 => SamePGType - (alias0 ::: def0 :=> nullity0 ty0) - (alias1 ::: def1 :=> nullity1 ty1) - --- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. -type family AllNotNull (columns :: ColumnsType) :: Constraint where - AllNotNull '[] = () - AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns - --- | `NotAllNull` is a constraint that proves a `ColumnsType` has some --- @NOT NULL@. -type family NotAllNull (columns :: ColumnsType) :: Constraint where - NotAllNull (column ::: def :=> 'NotNull ty ': columns) = () - NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns - --- | `NullifyType` is an idempotent that nullifies a `NullityType`. -type family NullifyType (ty :: NullityType) :: NullityType where - NullifyType ('Null ty) = 'Null ty - NullifyType ('NotNull ty) = 'Null ty - --- | `NullifyRow` is an idempotent that nullifies a `RowType`. -type family NullifyRow (columns :: RowType) :: RowType where - NullifyRow '[] = '[] - NullifyRow (column ::: ty ': columns) = - column ::: NullifyType ty ': NullifyRow columns - --- | `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`. -type family NullifyFrom (tables :: FromType) :: FromType where - NullifyFrom '[] = '[] - NullifyFrom (table ::: columns ': tables) = - table ::: NullifyRow columns ': NullifyFrom tables - --- | @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`. -type family Create alias x xs where - Create alias x '[] = '[alias ::: x] - Create alias x (alias ::: y ': xs) = TypeError - ('Text "Create: alias " - ':<>: 'ShowType alias - ':<>: 'Text "already in use") - Create alias y (x ': xs) = x ': Create alias y xs - --- | @Drop alias xs@ removes the type associated with @alias@ in @xs@ --- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements --- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements. -type family Drop alias xs where - Drop alias ((alias ::: x) ': xs) = xs - Drop alias (x ': xs) = x ': Drop alias xs - --- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@ --- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable` --- and `Squeal.PostgreSQL.Definition.alterColumn`. -type family Alter alias x xs where - Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs - Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs - --- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@ --- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and --- `Squeal.PostgreSQL.Definition.renameColumn`. -type family Rename alias0 alias1 xs where - Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs - Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs - --- | 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) - = column `Elem` columns - --- | Drop all `TableConstraint`s that involve a column -type family DropIfConstraintsInvolve column constraints where - DropIfConstraintsInvolve column '[] = '[] - DropIfConstraintsInvolve column (alias ::: constraint ': constraints) - = If (ConstraintInvolves column constraint) - (DropIfConstraintsInvolve column constraints) - (alias ::: constraint ': DropIfConstraintsInvolve column constraints) - --- | A `SchemumType` is a user-defined type, either a `Table`, --- `View` or `Typedef`. -data SchemumType - = Table TableType - | View RowType - | Typedef PGType - -{- | The schema of a database consists of a list of aliased, -user-defined `SchemumType`s. - ->>> :{ -type family Schema :: SchemaType where - Schema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) - , "emails" ::: 'Table ( - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) - ] -:} --} -type SchemaType = [(Symbol,SchemumType)] - -{- | -A database contains one or more named schemas, which in turn contain tables. -The same object name can be used in different schemas without conflict; -for example, both schema1 and myschema can contain tables named mytable. -Unlike databases, schemas are not rigidly separated: -a user can access objects in any of the schemas in the database they are connected to, -if they have privileges to do so. - -There are several reasons why one might want to use schemas: - - * To allow many users to use one database without interfering with each other. - * To organize database objects into logical groups to make them more manageable. - * Third-party applications can be put into separate schemas - so they do not collide with the names of other objects. --} -type SchemasType = [(Symbol,SchemaType)] - --- | A type family to use for a single schema database. -type family Public (schema :: SchemaType) :: SchemasType - where Public schema = '["public" ::: schema] - --- | `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"`. -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 --- | A `PGlabel` unit type with an `IsPGlabel` instance -data PGlabel (label :: Symbol) = PGlabel -instance KnownSymbol label => RenderSQL (PGlabel label) where - renderSQL _ = "\'" <> renderSymbol @label <> "\'" -instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where - renderSQL - = commaSeparated - . hcollapse - . hcmap (Proxy @KnownSymbol) (K . renderSQL) - --- | Is a type a valid JSON key? -type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ] - --- | Is a type a valid JSON type? -type PGJsonType = '[ 'PGjson, 'PGjsonb ] - --- | Utility class for `AllUnique` to provide nicer error messages. -class IsNotElem x isElem where -instance IsNotElem x 'False where -instance (TypeError ( 'Text "Cannot assign to " - ':<>: 'ShowType alias - ':<>: 'Text " more than once")) - => IsNotElem '(alias, a) 'True where - --- | No elem of @xs@ appears more than once, in the context of assignment. -class AllUnique (xs :: [(Symbol, a)]) where -instance AllUnique '[] where -instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where diff --git a/src/Squeal/PostgreSQL/Session.hs b/src/Squeal/PostgreSQL/Session.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session.hs @@ -0,0 +1,333 @@ +{-| +Module: Squeal.PostgreSQL.Session +Description: sessions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Using Squeal in your application will come down to defining +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 #-} +{-# LANGUAGE + DefaultSignatures + , FunctionalDependencies + , FlexibleContexts + , FlexibleInstances + , InstanceSigs + , OverloadedStrings + , PolyKinds + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Session + ( PQ (PQ, unPQ) + , runPQ + , execPQ + , evalPQ + , withConnection + ) where + +import Control.Applicative +import Control.Category +import Control.Monad (MonadPlus(..)) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Catch +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) +import UnliftIO (MonadUnliftIO(..)) +import Data.ByteString (ByteString) +import Data.Functor ((<&>)) +import Data.Hashable +import Data.Kind +import Data.String +import Generics.SOP +import PostgreSQL.Binary.Encoding (encodingBytes) +import Prelude hiding (id, (.)) + +import qualified Control.Monad.Fail as Fail +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoding as Encoding + +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Session.Connection +import Squeal.PostgreSQL.Session.Encode +import Squeal.PostgreSQL.Session.Exception +import Squeal.PostgreSQL.Session.Indexed +import Squeal.PostgreSQL.Session.Oid +import Squeal.PostgreSQL.Session.Monad +import Squeal.PostgreSQL.Session.Result +import Squeal.PostgreSQL.Session.Statement +import Squeal.PostgreSQL.Type.Schema + +-- | We keep track of the schema via an Atkey indexed state monad transformer, +-- `PQ`. +newtype PQ + (db0 :: SchemasType) + (db1 :: SchemasType) + (m :: Type -> Type) + (x :: Type) = + PQ { unPQ :: K LibPQ.Connection db0 -> m (K x db1) } + +instance Monad m => Functor (PQ db0 db1 m) where + fmap f (PQ pq) = PQ $ \ conn -> do + K x <- pq conn + return $ K (f x) + +-- | Run a `PQ` and keep the result and the `LibPQ.Connection`. +runPQ + :: Functor m + => PQ db0 db1 m x + -> K LibPQ.Connection db0 + -> m (x, K LibPQ.Connection db1) +runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn + -- K x <- pq conn + -- return (x, K (unK conn)) + +-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`. +execPQ + :: Functor m + => PQ db0 db1 m x + -> K LibPQ.Connection db0 + -> m (K LibPQ.Connection db1) +execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn + +-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result. +evalPQ + :: Functor m + => PQ db0 db1 m x + -> K LibPQ.Connection db0 + -> m x +evalPQ (PQ pq) conn = unK <$> pq conn + +instance IndexedMonadTrans PQ where + + pqAp (PQ f) (PQ x) = PQ $ \ conn -> do + K f' <- f conn + K x' <- x (K (unK conn)) + return $ K (f' x') + + pqBind f (PQ x) = PQ $ \ conn -> do + K x' <- x conn + unPQ (f x') (K (unK conn)) + +instance IndexedMonadTransPQ PQ where + + define (UnsafeDefinition q) = PQ $ \ (K conn) -> liftIO $ do + resultMaybe <- LibPQ.exec conn q + case resultMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.exec" + Just result -> K <$> okResult_ result + +instance (MonadIO io, db0 ~ db, db1 ~ db) => MonadPQ db (PQ db0 db1 io) where + + executeParams (Manipulation encode decode (UnsafeManipulation q)) x = + PQ $ \ kconn@(K conn) -> liftIO $ do + let + formatParam + :: forall param. OidOfNull db param + => K (Maybe Encoding.Encoding) param + -> IO (K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param) + formatParam (K maybeEncoding) = do + oid <- runReaderT (oidOfNull @db @param) kconn + return . K $ maybeEncoding <&> \encoding -> + (oid, encodingBytes encoding, LibPQ.Binary) + encodedParams <- runReaderT (runEncodeParams encode x) kconn + formattedParams <- hcollapse <$> + hctraverse' (Proxy @(OidOfNull db)) formatParam encodedParams + resultMaybe <- + LibPQ.execParams conn (q <> ";") formattedParams LibPQ.Binary + case resultMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.execParams" + Just result -> do + okResult_ result + return $ K (Result decode result) + executeParams (Query encode decode q) x = + executeParams (Manipulation encode decode (queryStatement q)) x + + prepare (Manipulation encode decode (UnsafeManipulation q :: Manipulation '[] db params row)) = do + let + statementNum = fromString $ case show (hash q) of + '-':num -> "negative_" <> num + num -> num + + prepName = "prepared_statement_" <> statementNum + + prepare' = PQ $ \ kconn@(K conn) -> liftIO $ do + let + oidOfParam :: forall p. OidOfNull db p => (IO :.: K LibPQ.Oid) p + oidOfParam = Comp $ K <$> runReaderT (oidOfNull @db @p) kconn + oidsOfParams :: NP (IO :.: K LibPQ.Oid) params + oidsOfParams = hcpure (Proxy @(OidOfNull db)) oidOfParam + oids <- hcollapse <$> hsequence' oidsOfParams + prepResultMaybe <- LibPQ.prepare conn prepName (q <> ";") (Just oids) + case prepResultMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.prepare" + Just prepResult -> K <$> okResult_ prepResult + + deallocate' = manipulate_ . UnsafeManipulation $ + "DEALLOCATE" <+> prepName + + runPrepared' params = PQ $ \ kconn@(K conn) -> liftIO $ do + encodedParams <- runReaderT (runEncodeParams encode params) kconn + let + formatParam encoding = (encodingBytes encoding, LibPQ.Binary) + formattedParams = + [ formatParam <$> maybeParam + | maybeParam <- hcollapse encodedParams + ] + resultMaybe <- + LibPQ.execPrepared conn prepName formattedParams LibPQ.Binary + case resultMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.runPrepared" + Just result -> do + okResult_ result + return . K $ Result decode result + + prepare' + return $ Prepared runPrepared' deallocate' + + prepare (Query encode decode q) = prepare (Manipulation encode decode (queryStatement q)) + +instance (Monad m, db0 ~ db1) + => Applicative (PQ db0 db1 m) where + pure x = PQ $ \ _conn -> pure (K x) + (<*>) = pqAp + +instance (Monad m, db0 ~ db1) + => Monad (PQ db0 db1 m) where + return = pure + (>>=) = flip pqBind + +instance (MonadFail m, db0 ~ db1) + => Fail.MonadFail (PQ db0 db1 m) where + fail = lift . Fail.fail + +instance db0 ~ db1 => MFunctor (PQ db0 db1) where + hoist f (PQ pq) = PQ (f . pq) + +instance db0 ~ db1 => MonadTrans (PQ db0 db1) where + lift m = PQ $ \ _conn -> do + x <- m + return (K x) + +instance db0 ~ db1 => MMonad (PQ db0 db1) where + embed f (PQ pq) = PQ $ \ conn -> do + evalPQ (f (pq conn)) conn + +instance (MonadIO m, schema0 ~ schema1) + => MonadIO (PQ schema0 schema1 m) where + liftIO = lift . liftIO + +instance (MonadUnliftIO m, db0 ~ db1) + => MonadUnliftIO (PQ db0 db1 m) where + withRunInIO + :: ((forall a . PQ db0 schema1 m a -> IO a) -> IO b) + -> PQ db0 schema1 m b + 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 + +instance (Monad m, Monoid r, db0 ~ db1) => Monoid (PQ db0 db1 m r) where + mempty = pure mempty + +instance MonadFix m => MonadFix (PQ db db m) where + mfix f = PQ $ \conn -> mfix $ \ (K a) -> K <$> evalPQ (f a) conn + +instance (Monad m, Alternative m, db0 ~ db1) + => Alternative (PQ db0 db1 m) where + empty = lift empty + altL <|> altR = PQ $ \ conn -> fmap K $ + evalPQ altL conn <|> evalPQ altR conn + +instance (MonadPlus m, db0 ~ db1) => MonadPlus (PQ db0 db1 m) + +-- | Do `connectdb` and `finish` before and after a computation. +withConnection + :: forall db0 db1 io x + . (MonadIO io, MonadMask io) + => ByteString + -> PQ db0 db1 io x + -> io x +withConnection connString action = + unK <$> bracket (connectdb connString) finish (unPQ action) + +okResult_ :: MonadIO io => LibPQ.Result -> io () +okResult_ result = liftIO $ do + status <- LibPQ.resultStatus result + case status of + LibPQ.CommandOk -> return () + LibPQ.TuplesOk -> return () + _ -> do + stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate + case stateCodeMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.resultErrorField" + Just stateCode -> do + msgMaybe <- LibPQ.resultErrorMessage result + case msgMaybe of + Nothing -> throwM $ ConnectionException "LibPQ.resultErrorMessage" + Just msg -> throwM . SQLException $ SQLState status stateCode msg diff --git a/src/Squeal/PostgreSQL/Session/Connection.hs b/src/Squeal/PostgreSQL/Session/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Connection.hs @@ -0,0 +1,78 @@ +{-| +Module: Squeal.PostgreSQL.Session.Connection +Description: database connections +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +database connections +-} + +{-# LANGUAGE + DataKinds + , PolyKinds + , RankNTypes + , TypeOperators +#-} + +module Squeal.PostgreSQL.Session.Connection + ( LibPQ.Connection + , connectdb + , finish + , lowerConnection + , SOP.K (..) + , SOP.unK + ) where + +import Control.Monad.IO.Class +import Data.ByteString (ByteString) + +import Squeal.PostgreSQL.Type.Schema + +import qualified Generics.SOP as SOP +import qualified Database.PostgreSQL.LibPQ as LibPQ + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | Makes a new connection to the database server. + +This function opens a new database connection using the parameters taken +from the string conninfo. + +The passed string can be empty to use all default parameters, or it can +contain one or more parameter settings separated by whitespace. +Each parameter setting is in the form keyword = value. Spaces around the equal +sign are optional. To write an empty value or a value containing spaces, +surround it with single quotes, e.g., keyword = 'a value'. Single quotes and +backslashes within the value must be escaped with a backslash, i.e., ' and \. + +To specify the schema you wish to connect with, use type application. + +>>> :set -XDataKinds +>>> :set -XPolyKinds +>>> :set -XTypeOperators +>>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]] +>>> :set -XTypeApplications +>>> :set -XOverloadedStrings +>>> 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! +-} +connectdb + :: forall (db :: SchemasType) io + . MonadIO io + => ByteString -- ^ conninfo + -> io (SOP.K LibPQ.Connection db) +connectdb = fmap SOP.K . liftIO . LibPQ.connectdb + +-- | Closes the connection to the server. +finish :: MonadIO io => SOP.K LibPQ.Connection db -> io () +finish = liftIO . LibPQ.finish . SOP.unK + +-- | Safely `lowerConnection` to a smaller schema. +lowerConnection + :: SOP.K LibPQ.Connection (schema ': db) + -> SOP.K LibPQ.Connection db +lowerConnection (SOP.K conn) = SOP.K conn diff --git a/src/Squeal/PostgreSQL/Session/Decode.hs b/src/Squeal/PostgreSQL/Session/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Decode.hs @@ -0,0 +1,698 @@ +{-| +Module: Squeal.PostgreSQL.Session.Decode +Description: decoding of result values +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +decoding of result values +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , CPP + , DataKinds + , DerivingStrategies + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PolyKinds + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Session.Decode + ( -- * Decode Types + FromPG (..) + , devalue + , rowValue + , enumValue + -- * Decode Rows + , DecodeRow (..) + , decodeRow + , runDecodeRow + , GenericRow (..) + , genericProductRow + , appendRows + , consRow + , ArrayField (..) + -- * Decoding Classes + , FromValue (..) + , FromField (..) + , FromAliasedValue (..) + , FromArray (..) + , StateT (..) + , ExceptT (..) + ) where + +import BinaryParser +import Control.Applicative +import Control.Arrow +import Control.Monad +#if MIN_VERSION_base(4,13,0) +#else +import Control.Monad.Fail +#endif +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe +import Data.Bits +import Data.Coerce (coerce) +import Data.Functor.Constant (Constant(Constant)) +import Data.Int (Int16, Int32, Int64) +#if MIN_VERSION_postgresql_binary(0, 14, 0) +import Data.IP (IPRange) +#else +import Network.IP.Addr (NetAddr, IP) +#endif +import Data.Kind +import Data.Scientific (Scientific) +import Data.String (fromString) +import Data.Text (Text) +import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime) +import Data.UUID.Types (UUID) +import Data.Vector (Vector) +import Database.PostgreSQL.LibPQ (Oid(Oid)) +import GHC.OverloadedLabels +import GHC.TypeLits +import PostgreSQL.Binary.Decoding hiding (Composite) +import Unsafe.Coerce + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text as Strict (Text) +import qualified Data.Text as Strict.Text +import qualified Data.Vector as Vector +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Record as SOP + +import Squeal.PostgreSQL.Expression.Range +import Squeal.PostgreSQL.Type +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.PG +import Squeal.PostgreSQL.Type.Schema + +-- | Converts a `Value` type from @postgresql-binary@ for use in +-- the `fromPG` method of `FromPG`. +devalue :: Value x -> StateT Strict.ByteString (Except Strict.Text) x +devalue = unsafeCoerce + +revalue :: StateT Strict.ByteString (Except Strict.Text) x -> Value x +revalue = unsafeCoerce + +{- | +>>> :set -XTypeFamilies +>>> :{ +data Complex = Complex + { real :: Double + , imaginary :: Double + } +instance IsPG Complex where + type PG Complex = 'PGcomposite '[ + "re" ::: 'NotNull 'PGfloat8, + "im" ::: 'NotNull 'PGfloat8] +instance FromPG Complex where + fromPG = rowValue $ do + re <- #re + im <- #im + return Complex {real = re, imaginary = im} +:} +-} +rowValue + :: (PG y ~ 'PGcomposite row, SOP.SListI row) + => DecodeRow row y -- ^ fields + -> StateT Strict.ByteString (Except Strict.Text) y +rowValue decoder = devalue $ + let + -- + -- [for each field] + -- + -- [if value is NULL] + -- <-1: 4 bytes> + -- [else] + -- + -- bytes> + -- [end if] + -- [end for] + comp = valueParser $ do + unitOfSize 4 + SOP.hsequence' $ SOP.hpure $ SOP.Comp $ do + unitOfSize 4 + len :: Int32 <- sized 4 int + if len == -1 + then return (SOP.K Nothing) + else SOP.K . Just <$> bytesOfSize (fromIntegral len) + in fn (runDecodeRow decoder <=< comp) + +-- | A `FromPG` constraint gives a parser from the binary format of +-- a PostgreSQL `PGType` into a Haskell `Type`. +class IsPG y => FromPG y where + {- | + >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XDerivingStrategies -XDerivingVia -XUndecidableInstances + >>> import GHC.Generics as GHC + >>> :{ + newtype UserId = UserId { getId :: Int64 } + deriving newtype (IsPG, FromPG) + :} + + >>> :{ + data Complex = Complex + { real :: Double + , imaginary :: Double + } deriving stock GHC.Generic + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + 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 + :} + + -} + fromPG :: StateT Strict.ByteString (Except Strict.Text) y +instance FromPG Bool where + fromPG = devalue bool +instance FromPG Int16 where + fromPG = devalue int +instance FromPG Int32 where + fromPG = devalue int +instance FromPG Int64 where + fromPG = devalue int +instance FromPG Oid where + fromPG = devalue $ Oid <$> int +instance FromPG Float where + fromPG = devalue float4 +instance FromPG Double where + fromPG = devalue float8 +instance FromPG Scientific where + fromPG = devalue numeric +instance FromPG Money where + fromPG = devalue $ Money <$> int +instance FromPG UUID where + fromPG = devalue uuid +#if MIN_VERSION_postgresql_binary(0, 14, 0) +instance FromPG IPRange where fromPG = devalue inet +#else +instance FromPG (NetAddr IP) where fromPG = devalue inet +#endif +instance FromPG Char where + fromPG = devalue char +instance FromPG Strict.Text where + fromPG = devalue text_strict +instance FromPG Lazy.Text where + fromPG = devalue text_lazy +instance FromPG String where + fromPG = devalue $ Strict.Text.unpack <$> text_strict +instance FromPG Strict.ByteString where + 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 x => FromPG (Const x tag) where + fromPG = coerce $ fromPG @x +instance FromPG x => FromPG (SOP.K x tag) where + fromPG = coerce $ fromPG @x +instance FromPG x => FromPG (Constant x tag) where + fromPG = coerce $ fromPG @x +instance FromPG Day where + fromPG = devalue date +instance FromPG TimeOfDay where + fromPG = devalue time_int +instance FromPG (TimeOfDay, TimeZone) where + fromPG = devalue timetz_int +instance FromPG LocalTime where + fromPG = devalue timestamp_int +instance FromPG UTCTime where + fromPG = devalue timestamptz_int +instance FromPG DiffTime where + fromPG = devalue interval_int +instance FromPG Aeson.Value where + fromPG = devalue json_ast +instance Aeson.FromJSON x => FromPG (Json x) where + fromPG = devalue $ Json <$> + json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict) +instance Aeson.FromJSON x => FromPG (Jsonb x) where + fromPG = devalue $ Jsonb <$> + jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict) +instance (FromArray '[] ty y, ty ~ NullPG y) + => FromPG (VarArray (Vector y)) where + fromPG = + let + rep n x = VarArray <$> Vector.replicateM n x + in + devalue . array $ dimensionArray rep + (fromArray @'[] @(NullPG y)) +instance (FromArray '[] ty y, ty ~ NullPG y) + => FromPG (VarArray [y]) where + fromPG = + let + rep n x = VarArray <$> replicateM n x + in + devalue . array $ dimensionArray rep + (fromArray @'[] @(NullPG y)) +instance FromArray dims ty y => FromPG (FixArray y) where + fromPG = devalue $ FixArray <$> array (fromArray @dims @ty @y) +instance + ( SOP.IsEnumType y + , SOP.HasDatatypeInfo y + , LabelsPG y ~ labels + ) => FromPG (Enumerated y) where + fromPG = + let + greadConstructor + :: SOP.All ((~) '[]) xss + => NP SOP.ConstructorInfo xss + -> String + -> Maybe (SOP.SOP SOP.I xss) + greadConstructor Nil _ = Nothing + greadConstructor (constructor :* constructors) name = + if name == SOP.constructorName constructor + then Just (SOP.SOP (SOP.Z Nil)) + else SOP.SOP . SOP.S . SOP.unSOP <$> + greadConstructor constructors name + in + devalue + $ fmap Enumerated + . enum + $ fmap SOP.to + . greadConstructor + (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @y))) + . Strict.Text.unpack +instance + ( SOP.IsRecord y ys + , SOP.AllZip FromField row ys + , RowPG y ~ row + ) => FromPG (Composite y) where + fromPG = rowValue (Composite <$> genericRow) +instance FromPG y => FromPG (Range y) where + fromPG = devalue $ do + flag <- byte + if testBit flag 0 then return Empty else do + lower <- + if testBit flag 3 + then return Infinite + else do + len <- sized 4 int + l <- sized len (revalue fromPG) + return $ if testBit flag 1 then Closed l else Open l + upper <- + if testBit flag 4 + then return Infinite + else do + len <- sized 4 int + l <- sized len (revalue fromPG) + return $ if testBit flag 2 then Closed l else Open l + return $ NonEmpty lower upper + +-- | A `FromValue` constraint lifts the `FromPG` parser +-- to a decoding of a @NullityType@ to a `Type`, +-- decoding `Null`s to `Maybe`s. You should not define instances for +-- `FromValue`, just use the provided instances. +class FromValue (ty :: NullType) (y :: Type) where + fromValue :: Maybe Strict.ByteString -> Either Strict.Text y +instance (FromPG y, pg ~ PG y) => FromValue ('NotNull pg) y where + fromValue = \case + Nothing -> throwError "fromField: saw NULL when expecting NOT NULL" + Just bytestring -> valueParser (revalue fromPG) bytestring +instance (FromPG y, pg ~ PG y) => FromValue ('Null pg) (Maybe y) where + fromValue = \case + Nothing -> return Nothing + Just bytestring -> fmap Just $ valueParser (revalue fromPG) bytestring + +-- | A `FromField` constraint lifts the `FromPG` parser +-- to a decoding of a @(Symbol, NullityType)@ to a `Type`, +-- decoding `Null`s to `Maybe`s. You should not define instances for +-- `FromField`, just use the provided instances. +class FromField (field :: (Symbol, NullType)) (y :: (Symbol, Type)) where + fromField :: Maybe Strict.ByteString -> Either Strict.Text (SOP.P y) +instance (FromValue ty y, fld0 ~ fld1) + => FromField (fld0 ::: ty) (fld1 ::: y) where + fromField = fmap SOP.P . fromValue @ty + +-- | A `FromArray` constraint gives a decoding to a Haskell `Type` +-- from the binary format of a PostgreSQL fixed-length array. +-- You should not define instances for +-- `FromArray`, just use the provided instances. +class FromArray (dims :: [Nat]) (ty :: NullType) (y :: Type) where + fromArray :: Array y +instance (FromPG y, pg ~ PG y) => FromArray '[] ('NotNull pg) y where + fromArray = valueArray (revalue fromPG) +instance (FromPG y, pg ~ PG y) => FromArray '[] ('Null pg) (Maybe y) where + fromArray = nullableValueArray (revalue fromPG) +instance + ( SOP.IsProductType product ys + , Length ys ~ dim + , SOP.All ((~) y) ys + , FromArray dims ty y ) + => FromArray (dim ': dims) ty product where + fromArray = + let + rep _ = fmap (SOP.to . SOP.SOP . SOP.Z) . replicateMN + in + dimensionArray rep (fromArray @dims @ty @y) + +replicateMN + :: forall x xs m. (SOP.All ((~) x) xs, Monad m, SOP.SListI xs) + => m x -> m (SOP.NP SOP.I xs) +replicateMN mx = SOP.hsequence' $ + SOP.hcpure (SOP.Proxy :: SOP.Proxy ((~) x)) (SOP.Comp (SOP.I <$> mx)) + +{- | +`DecodeRow` describes a decoding of a PostgreSQL `RowType` +into a Haskell `Type`. + +`DecodeRow` has an interface given by the classes +`Functor`, `Applicative`, `Alternative`, `Monad`, +`MonadPlus`, `MonadError` `Strict.Text`, and `IsLabel`. + +>>> :set -XOverloadedLabels +>>> :{ +let + decode :: DecodeRow + '[ "fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)] + (Int16, Char) + decode = (,) <$> #fst <*> #snd +in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil) +:} +Right (1,'a') + +There is also an `IsLabel` instance for `MaybeT` `DecodeRow`s, useful +for decoding outer joined rows. + +>>> :{ +let + decode :: DecodeRow + '[ "fst" ::: 'Null 'PGint2, "snd" ::: 'Null ('PGchar 1)] + (Maybe (Int16, Char)) + decode = runMaybeT $ (,) <$> #fst <*> #snd +in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil) +:} +Right (Just (1,'a')) + +-} +newtype DecodeRow (row :: RowType) (y :: Type) = DecodeRow + { unDecodeRow :: ReaderT + (SOP.NP (SOP.K (Maybe Strict.ByteString)) row) (Except Strict.Text) y } + deriving newtype + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadError Strict.Text ) +instance MonadFail (DecodeRow row) where + fail = throwError . fromString + +-- | Run a `DecodeRow`. +runDecodeRow + :: DecodeRow row y + -> SOP.NP (SOP.K (Maybe Strict.ByteString)) row + -> 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) + -> DecodeRow row y +decodeRow dec = DecodeRow . ReaderT $ liftEither . dec +instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty y) + => IsLabel fld (DecodeRow (fld ::: ty ': row) y) where + fromLabel = decodeRow $ \(SOP.K b SOP.:* _) -> do + let + flderr = mconcat + [ "field name: " + , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; " + ] + left (flderr <>) $ fromValue @ty b +instance {-# OVERLAPPABLE #-} IsLabel fld (DecodeRow row y) + => IsLabel fld (DecodeRow (field ': row) y) where + fromLabel = decodeRow $ \(_ SOP.:* bs) -> + runDecodeRow (fromLabel @fld) bs +instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty (Maybe y)) + => IsLabel fld (MaybeT (DecodeRow (fld ::: ty ': row)) y) where + fromLabel = MaybeT . decodeRow $ \(SOP.K b SOP.:* _) -> do + let + flderr = mconcat + [ "field name: " + , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; " + ] + left (flderr <>) $ fromValue @ty b +instance {-# OVERLAPPABLE #-} IsLabel fld (MaybeT (DecodeRow row) y) + => IsLabel fld (MaybeT (DecodeRow (field ': row)) y) where + fromLabel = MaybeT . decodeRow $ \(_ SOP.:* bs) -> + runDecodeRow (runMaybeT (fromLabel @fld)) bs + +{- | Utility for decoding array fields in a `DecodeRow`, +accessed via overloaded labels. +-} +newtype ArrayField row y = ArrayField + { runArrayField + :: StateT Strict.ByteString (Except Strict.Text) y + -> DecodeRow row [y] + } +instance {-# OVERLAPPING #-} + ( KnownSymbol fld + , PG y ~ ty + , arr ~ 'NotNull ('PGvararray ('NotNull ty)) + ) => IsLabel fld (ArrayField (fld ::: arr ': row) y) where + fromLabel = ArrayField $ \yval -> + decodeRow $ \(SOP.K bytesMaybe SOP.:* _) -> do + let + flderr = mconcat + [ "field name: " + , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; " + ] + yarr + = devalue + . array + . dimensionArray replicateM + . valueArray + . revalue + $ yval + case bytesMaybe of + Nothing -> Left (flderr <> "encountered unexpected NULL") + Just bytes -> runExcept (evalStateT yarr bytes) +instance {-# OVERLAPPABLE #-} IsLabel fld (ArrayField row y) + => IsLabel fld (ArrayField (field ': row) y) where + fromLabel = ArrayField $ \yval -> + decodeRow $ \(_ SOP.:* bytess) -> + runDecodeRow (runArrayField (fromLabel @fld) yval) bytess + +-- | A `GenericRow` constraint to ensure that a Haskell type +-- is a record type, +-- has a `RowPG`, +-- and all its fields and can be decoded from corresponding Postgres fields. +class + ( SOP.IsRecord y ys + , row ~ RowPG y + , SOP.AllZip FromField row ys + ) => GenericRow row y ys where + {- | Row decoder for `SOP.Generic` records. + + >>> import qualified GHC.Generics as GHC + >>> import qualified Generics.SOP as SOP + >>> data Two = Two {frst :: Int16, scnd :: String} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo) + >>> :{ + let + decode :: DecodeRow '[ "frst" ::: 'NotNull 'PGint2, "scnd" ::: 'NotNull 'PGtext] Two + decode = genericRow + in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil) + :} + Right (Two {frst = 2, scnd = "two"}) + -} + genericRow :: DecodeRow row y +instance + ( row ~ RowPG y + , SOP.IsRecord y ys + , SOP.AllZip FromField row ys + ) => GenericRow row y ys where + genericRow + = DecodeRow + . ReaderT + $ fmap SOP.fromRecord + . SOP.hsequence' + . SOP.htrans (SOP.Proxy @FromField) runField + where + runField + :: forall ty z. FromField ty z + => SOP.K (Maybe Strict.ByteString) ty + -> (Except Strict.Text SOP.:.: SOP.P) z + runField + = SOP.Comp + . liftEither + . fromField @ty + . SOP.unK + +{- | Assistant class for `genericProductRow`, +this class forgets the name of a field while decoding it. +-} +class FromAliasedValue (field :: (Symbol, NullType)) (y :: Type) where + fromAliasedValue :: Maybe Strict.ByteString -> Either Strict.Text y +instance FromValue ty y => FromAliasedValue (fld ::: ty) y where + fromAliasedValue = fromValue @ty + +{- | Positionally `DecodeRow`. More general than `genericRow`, +which matches records both positionally and by field name, +`genericProductRow` matches records _or_ tuples purely positionally. + +>>> import qualified GHC.Generics as GHC +>>> import qualified Generics.SOP as SOP +>>> :{ +let + decode :: DecodeRow '[ "foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGtext] (Int16, String) + decode = genericProductRow +in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil) +:} +Right (2,"two") +-} +genericProductRow + :: ( SOP.IsProductType y ys + , SOP.AllZip FromAliasedValue row ys + ) + => DecodeRow row y +genericProductRow + = DecodeRow + . ReaderT + $ fmap SOP.productTypeTo + . SOP.hsequence' + . SOP.htrans (SOP.Proxy @FromAliasedValue) runField + where + runField + :: forall ty z. FromAliasedValue ty z + => SOP.K (Maybe Strict.ByteString) ty + -> (Except Strict.Text SOP.:.: SOP.I) z + runField + = SOP.Comp + . fmap SOP.I + . liftEither + . fromAliasedValue @ty + . SOP.unK + +{- | +>>> :{ +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 -- ^ 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 new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Encode.hs @@ -0,0 +1,681 @@ +{-| +Module: Squeal.PostgreSQL.Session.Encode +Description: encoding of statement parameters +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +encoding of statement parameters +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , CPP + , DataKinds + , DefaultSignatures + , FlexibleContexts + , FlexibleInstances + , LambdaCase + , MultiParamTypeClasses + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Session.Encode + ( -- * Encode Parameters + EncodeParams (..) + , GenericParams (..) + , nilParams + , (.*) + , (*.) + , aParam + , appendParams + , enumParam + , rowParam + , genericRowParams + , (.#) + , (#.) + -- * Encoding Classes + , ToPG (..) + , ToParam (..) + , ToField (..) + , ToArray (..) + ) where + +import ByteString.StrictBuilder +import Control.Monad +import Control.Monad.Reader +import Data.Bits +import Data.ByteString as Strict (ByteString) +import Data.ByteString.Lazy as Lazy (ByteString) +import Data.Coerce (coerce) +import Data.Functor.Const (Const(Const)) +import Data.Functor.Constant (Constant(Constant)) +import Data.Functor.Contravariant +import Data.Int (Int16, Int32, Int64) +#if MIN_VERSION_postgresql_binary(0, 14, 0) +import Data.IP (IPRange) +#else +import Network.IP.Addr (NetAddr, IP) +#endif +import Data.Kind +import Data.Scientific (Scientific) +import Data.Text as Strict (Text) +import Data.Text.Lazy as Lazy (Text) +import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime) +import Data.UUID.Types (UUID) +import Data.Vector (Vector) +import Data.Word (Word32) +import Foreign.C.Types (CUInt(CUInt)) +import GHC.TypeLits +import PostgreSQL.Binary.Encoding hiding (Composite, field) + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as Lazy.ByteString +import qualified Data.Text as Strict.Text +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Record as SOP + +import Squeal.PostgreSQL.Expression.Range +import Squeal.PostgreSQL.Session.Oid +import Squeal.PostgreSQL.Type +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.PG +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL (connectdb, finish) + +-- | A `ToPG` constraint gives an encoding of a Haskell `Type` into +-- 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 user=postgres password=postgres" + -- >>> runReaderT (toPG @'[] False) conn + -- "\NUL" + -- + -- >>> runReaderT (toPG @'[] (0 :: Int16)) conn + -- "\NUL\NUL" + -- + -- >>> runReaderT (toPG @'[] (0 :: Int32)) conn + -- "\NUL\NUL\NUL\NUL" + -- + -- >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving + -- >>> newtype UserId = UserId { getUserId :: Int64 } deriving newtype (IsPG, ToPG db) + -- >>> runReaderT (toPG @'[] (UserId 0)) conn + -- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL" + -- + -- >>> finish conn + toPG :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding +instance ToPG db Bool where toPG = pure . bool +instance ToPG db Int16 where toPG = pure . int2_int16 +instance ToPG db Int32 where toPG = pure . int4_int32 +instance ToPG db Int64 where toPG = pure . int8_int64 +instance ToPG db Oid where toPG = pure . int4_word32 . getOid +instance ToPG db Float where toPG = pure . float4 +instance ToPG db Double where toPG = pure . float8 +instance ToPG db Scientific where toPG = pure . numeric +instance ToPG db Money where toPG = pure . int8_int64 . cents +instance ToPG db UUID where toPG = pure . uuid +#if MIN_VERSION_postgresql_binary(0, 14, 0) +instance ToPG db IPRange where toPG = pure . inet +#else +instance ToPG db (NetAddr IP) where toPG = pure . inet +#endif +instance ToPG db Char where toPG = pure . char_utf8 +instance ToPG db Strict.Text where toPG = pure . text_strict +instance ToPG db Lazy.Text where toPG = pure . text_lazy +instance ToPG db String where + 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 x => ToPG db (Const x tag) where toPG = toPG @db @x . coerce +instance ToPG db x => ToPG db (SOP.K x tag) where toPG = toPG @db @x . coerce +instance ToPG db x => ToPG db (Constant x tag) where toPG = toPG @db @x . coerce +instance ToPG db Day where toPG = pure . date +instance ToPG db TimeOfDay where toPG = pure . time_int +instance ToPG db (TimeOfDay, TimeZone) where toPG = pure . timetz_int +instance ToPG db LocalTime where toPG = pure . timestamp_int +instance ToPG db UTCTime where toPG = pure . timestamptz_int +instance ToPG db DiffTime where toPG = pure . interval_int +instance ToPG db Aeson.Value where toPG = pure . json_ast +instance Aeson.ToJSON x => ToPG db (Json x) where + toPG = pure . json_bytes + . Lazy.ByteString.toStrict . Aeson.encode . getJson +instance Aeson.ToJSON x => ToPG db (Jsonb x) where + toPG = pure . jsonb_bytes + . Lazy.ByteString.toStrict . Aeson.encode . getJsonb +instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty) + => ToPG db (VarArray [x]) where + toPG (VarArray arr) = do + oid <- oidOfNull @db @ty + let + dims = [fromIntegral (length arr)] + nulls = arrayNulls @db @'[] @ty @x + payload <- dimArray foldM (arrayPayload @db @'[] @ty @x) arr + return $ encodeArray 1 nulls oid dims payload +instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty) + => ToPG db (VarArray (Vector x)) where + toPG (VarArray arr) = do + oid <- oidOfNull @db @ty + let + dims = [fromIntegral (length arr)] + nulls = arrayNulls @db @'[] @ty @x + payload <- dimArray foldM (arrayPayload @db @'[] @ty @x) arr + return $ encodeArray 1 nulls oid dims payload +instance (ToArray db dims ty x, OidOfNull db ty) + => ToPG db (FixArray x) where + toPG (FixArray arr) = do + oid <- oidOfNull @db @ty + payload <- arrayPayload @db @dims @ty arr + let + dims = arrayDims @db @dims @ty @x + nulls = arrayNulls @db @dims @ty @x + ndims = fromIntegral (length dims) + return $ encodeArray ndims nulls oid dims payload +instance + ( SOP.IsEnumType x + , SOP.HasDatatypeInfo x + , LabelsPG x ~ labels + ) => ToPG db (Enumerated x) where + toPG = + let + gshowConstructor + :: NP SOP.ConstructorInfo xss + -> SOP.SOP SOP.I xss + -> String + gshowConstructor Nil _ = "" + gshowConstructor (constructor :* _) (SOP.SOP (SOP.Z _)) = + SOP.constructorName constructor + gshowConstructor (_ :* constructors) (SOP.SOP (SOP.S xs)) = + gshowConstructor constructors (SOP.SOP xs) + in + pure + . text_strict + . Strict.Text.pack + . gshowConstructor + (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x))) + . SOP.from + . getEnumerated +instance + ( SOP.SListI fields + , SOP.IsRecord x xs + , SOP.AllZip (ToField db) fields xs + , SOP.All (OidOfField db) fields + , RowPG x ~ fields + ) => ToPG db (Composite x) where + toPG = rowParam (contramap getComposite genericRowParams) +instance ToPG db x => ToPG db (Range x) where + toPG r = do + payload <- case r of + Empty -> return mempty + NonEmpty lower upper -> (<>) <$> putBound lower <*> putBound upper + return $ word8 (setFlags r 0) <> payload + where + putBound = \case + Infinite -> return mempty + Closed value -> sized <$> toPG @db value + Open value -> sized <$> toPG @db value + setFlags = \case + Empty -> (`setBit` 0) + NonEmpty lower upper -> + setLowerFlags lower . setUpperFlags upper + setLowerFlags = \case + Infinite -> (`setBit` 3) + Closed _ -> (`setBit` 1) + Open _ -> id + setUpperFlags = \case + Infinite -> (`setBit` 4) + Closed _ -> (`setBit` 2) + Open _ -> id + +-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into +-- into the binary format of a PostgreSQL `NullType`. +-- You should not define instances for `ToParam`, +-- just use the provided instances. +class ToParam (db :: SchemasType) (ty :: NullType) (x :: Type) where + toParam :: x -> ReaderT (SOP.K LibPQ.Connection db) IO (Maybe Encoding) +instance (ToPG db x, pg ~ PG x) => ToParam db ('NotNull pg) x where + toParam = fmap Just . toPG @db +instance (ToPG db x, pg ~ PG x) => ToParam db ('Null pg) (Maybe x) where + toParam = maybe (pure Nothing) (fmap Just . toPG @db) + +-- | A `ToField` constraint lifts the `ToPG` parser +-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@, +-- encoding `Null`s to `Maybe`s. You should not define instances for +-- `ToField`, just use the provided instances. +class ToField + (db :: SchemasType) + (field :: (Symbol, NullType)) + (x :: (Symbol, Type)) where + toField :: SOP.P x + -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) field) +instance (fld0 ~ fld1, ToParam db ty x) + => ToField db (fld0 ::: ty) (fld1 ::: x) where + toField (SOP.P x) = SOP.K <$> toParam @db @ty x + +-- | A `ToArray` constraint gives an encoding of a Haskell `Type` +-- into the binary format of a PostgreSQL fixed-length array. +-- You should not define instances for +-- `ToArray`, just use the provided instances. +class ToArray + (db :: SchemasType) + (dims :: [Nat]) + (ty :: NullType) + (x :: Type) where + arrayPayload :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding + arrayDims :: [Int32] + arrayNulls :: Bool +instance (ToPG db x, pg ~ PG x) + => ToArray db '[] ('NotNull pg) x where + arrayPayload = fmap sized . toPG @db @x + arrayDims = [] + arrayNulls = False +instance (ToPG db x, pg ~ PG x) + => ToArray db '[] ('Null pg) (Maybe x) where + arrayPayload = maybe (pure null4) (fmap sized . toPG @db @x) + arrayDims = [] + arrayNulls = True +instance + ( SOP.IsProductType tuple xs + , Length xs ~ dim + , SOP.All ((~) x) xs + , ToArray db dims ty x + , KnownNat dim ) + => ToArray db (dim ': dims) ty tuple where + arrayPayload + = dimArray foldlNP (arrayPayload @db @dims @ty @x) + . SOP.unZ . SOP.unSOP . SOP.from + arrayDims + = fromIntegral (natVal (SOP.Proxy @dim)) + : arrayDims @db @dims @ty @x + arrayNulls = arrayNulls @db @dims @ty @x +foldlNP + :: (SOP.All ((~) x) xs, Monad m) + => (z -> x -> m z) -> z -> NP SOP.I xs -> m z +foldlNP f z = \case + Nil -> pure z + SOP.I x :* xs -> do + z' <- f z x + foldlNP f z' xs + +{- | +`EncodeParams` describes an encoding of a Haskell `Type` +into a list of parameter `NullType`s or into a `RowType`. + +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" +>>> :{ +let + encode :: EncodeParams '[] + '[ 'NotNull 'PGint2, 'NotNull ('PGchar 1), 'NotNull 'PGtext] + (Int16, (Char, String)) + encode = fst .* fst.snd *. snd.snd +in runReaderT (runEncodeParams encode (1,('a',"foo"))) conn +:} +K (Just "\NUL\SOH") :* K (Just "a") :* K (Just "foo") :* Nil + +>>> :{ +let + encode :: EncodeParams '[] + '["fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)] + (Int16, Char) + encode = fst `as` #fst #. snd `as` #snd +in runReaderT (runEncodeParams encode (1,'a')) conn +:} +K (Just "\NUL\SOH") :* K (Just "a") :* Nil + +>>> finish conn +-} +newtype EncodeParams + (db :: SchemasType) + (tys :: [k]) + (x :: Type) = EncodeParams + { runEncodeParams :: x + -> ReaderT (SOP.K LibPQ.Connection db) IO (NP (SOP.K (Maybe Encoding)) tys) } +instance Contravariant (EncodeParams db tys) where + contramap f (EncodeParams g) = EncodeParams (g . f) + +-- | A `GenericParams` constraint to ensure that a Haskell type +-- is a product type, +-- has a `TuplePG`, +-- and all its terms have known Oids, +-- and can be encoded to corresponding Postgres types. +class + ( SOP.IsProductType x xs + , params ~ TuplePG x + , SOP.All (OidOfNull db) params + , SOP.AllZip (ToParam db) params xs + ) => GenericParams db params x xs where + {- | Parameter encoding for `SOP.Generic` tuples and records. + + >>> import qualified GHC.Generics as GHC + >>> import qualified Generics.SOP as SOP + >>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic) + >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" + >>> :{ + let + encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two + encode = genericParams + in runReaderT (runEncodeParams encode (Two 2 "two")) conn + :} + K (Just "\NUL\STX") :* K (Just "two") :* Nil + + >>> :{ + let + encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] (Int16, String) + encode = genericParams + in runReaderT (runEncodeParams encode (2, "two")) conn + :} + K (Just "\NUL\STX") :* K (Just "two") :* Nil + + >>> finish conn + -} + genericParams :: EncodeParams db params x +instance + ( params ~ TuplePG x + , SOP.All (OidOfNull db) params + , SOP.IsProductType x xs + , SOP.AllZip (ToParam db) params xs + ) => GenericParams db params x xs where + genericParams = EncodeParams + $ hctransverse (SOP.Proxy @(ToParam db)) encodeNullParam + . SOP.unZ . SOP.unSOP . SOP.from + where + encodeNullParam + :: forall ty y. ToParam db ty y + => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty) + encodeNullParam = fmap SOP.K . toParam @db @ty . SOP.unI + +-- | Encode 0 parameters. +nilParams :: EncodeParams db '[] x +nilParams = EncodeParams $ \ _ -> pure Nil + +{- | Cons a parameter encoding. + +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" +>>> :{ +let + encode :: EncodeParams '[] + '[ 'Null 'PGint4, 'NotNull 'PGtext] + (Maybe Int32, String) + encode = fst .* snd .* nilParams +in runReaderT (runEncodeParams encode (Nothing, "foo")) conn +:} +K Nothing :* K (Just "foo") :* Nil + +>>> finish conn +-} +(.*) + :: forall db x0 ty x tys. (ToParam db ty x0, ty ~ NullPG x0) + => (x -> x0) -- ^ head + -> EncodeParams db tys x -- ^ tail + -> EncodeParams db (ty ': tys) x +f .* EncodeParams params = EncodeParams $ \x -> + (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x +infixr 5 .* + +{- | End a parameter encoding. + +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" +>>> :{ +let + encode :: EncodeParams '[] + '[ 'Null 'PGint4, 'NotNull 'PGtext, 'NotNull ('PGchar 1)] + (Maybe Int32, String, Char) + encode = (\(x,_,_) -> x) .* (\(_,y,_) -> y) *. (\(_,_,z) -> z) +in runReaderT (runEncodeParams encode (Nothing, "foo", 'z')) conn +:} +K Nothing :* K (Just "foo") :* K (Just "z") :* Nil + +>>> finish conn +-} +(*.) + :: forall db x x0 ty0 x1 ty1 + . ( ToParam db ty0 x0 + , ty0 ~ NullPG x0 + , ToParam db ty1 x1 + , ty1 ~ NullPG x1 + ) + => (x -> x0) -- ^ second to last + -> (x -> x1) -- ^ last + -> EncodeParams db '[ty0, ty1] x +f *. g = f .* g .* nilParams +infixl 8 *. + +{- | Encode 1 parameter. + +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" +>>> :{ +let + encode :: EncodeParams '[] '[ 'NotNull 'PGint4] Int32 + encode = aParam +in runReaderT (runEncodeParams encode 1776) conn +:} +K (Just "\NUL\NUL\ACK\240") :* Nil + +>>> finish conn +-} +aParam + :: forall db x ty. (ToParam db ty x, ty ~ NullPG x) + => EncodeParams db '[ty] x + -- ^ a single parameter +aParam = EncodeParams $ + fmap (\param -> SOP.K param :* Nil) . toParam @db @(NullPG x) + +{- | Append parameter encodings. + +>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" +>>> :{ +let + encode :: EncodeParams '[] + '[ 'NotNull 'PGint4, 'NotNull 'PGint2] + (Int32, Int16) + encode = contramap fst aParam `appendParams` contramap snd aParam +in runReaderT (runEncodeParams encode (1776, 2)) conn +:} +K (Just "\NUL\NUL\ACK\240") :* K (Just "\NUL\STX") :* Nil + +>>> finish conn +-} +appendParams + :: EncodeParams db params0 x -- ^ left + -> EncodeParams db params1 x -- ^ right + -> EncodeParams db (Join params0 params1) x +appendParams encode0 encode1 = EncodeParams $ \x -> also + <$> runEncodeParams encode1 x + <*> runEncodeParams encode0 x + +{- | +>>> :set -XLambdaCase -XFlexibleInstances +>>> :{ +data Dir = North | South | East | West +instance IsPG Dir where + type PG Dir = 'PGenum '["north", "south", "east", "west"] +instance ToPG db Dir where + toPG = enumParam $ \case + North -> label @"north" + South -> label @"south" + East -> label @"east" + West -> label @"west" +:} +-} +enumParam + :: (PG x ~ 'PGenum labels, SOP.All KnownSymbol labels) + => (x -> SOP.NS PGlabel labels) + -- ^ match cases with enum `label`s + -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding) +enumParam casesOf + = return + . text_strict + . Strict.Text.pack + . enumCases + . casesOf + where + enumCases + :: SOP.All KnownSymbol lbls + => SOP.NS PGlabel lbls + -> String + enumCases = \case + SOP.Z (_ :: PGlabel lbl) -> symbolVal (SOP.Proxy @lbl) + SOP.S cases -> enumCases cases + +{- | +>>> :set -XTypeFamilies -XFlexibleInstances +>>> :{ +data Complex = Complex + { real :: Double + , imaginary :: Double + } +instance IsPG Complex where + type PG Complex = 'PGcomposite '[ + "re" ::: 'NotNull 'PGfloat8, + "im" ::: 'NotNull 'PGfloat8] +instance ToPG db Complex where + toPG = rowParam $ real `as` #re #. imaginary `as` #im +:} +-} +rowParam + :: (PG x ~ 'PGcomposite row, SOP.All (OidOfField db) row) + => EncodeParams db row x + -- ^ use `(.#)` and `(#.)` to define a row parameter encoding + -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding) +rowParam (enc :: EncodeParams db row x) x = do + let + compositeSize + = int4_int32 + $ fromIntegral + $ SOP.lengthSList + $ SOP.Proxy @row + each + :: OidOfField db field + => SOP.K (Maybe Encoding) field + -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding + each (SOP.K field :: SOP.K (Maybe Encoding) field) = do + oid <- getOid <$> oidOfField @db @field + return $ int4_word32 oid <> maybe null4 sized field + fields <- runEncodeParams enc x + compositePayload <- hcfoldMapM + (SOP.Proxy @(OidOfField db)) each fields + return $ compositeSize <> compositePayload + +{- | Cons a row parameter encoding for `rowParam`. -} +(.#) + :: forall db x0 fld ty x tys. (ToParam db ty x0, ty ~ NullPG x0) + => Aliased ((->) x) (fld ::: x0) -- ^ head + -> EncodeParams db tys x -- ^ tail + -> EncodeParams db (fld ::: ty ': tys) x +(f `As` _) .# EncodeParams params = EncodeParams $ \x -> + (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x +infixr 5 .# + +{- | End a row parameter encoding for `rowParam`. -} +(#.) + :: forall db x x0 fld0 ty0 x1 fld1 ty1 + . ( ToParam db ty0 x0 + , ty0 ~ NullPG x0 + , ToParam db ty1 x1 + , ty1 ~ NullPG x1 + ) + => Aliased ((->) x) (fld0 ::: x0) -- ^ second to last + -> Aliased ((->) x) (fld1 ::: x1) -- ^ last + -> EncodeParams db '[fld0 ::: ty0, fld1 ::: ty1] x +f #. g = f .# g .# nilParams +infixl 8 #. + +instance (ToParam db ty x, ty ~ NullPG x) + => IsLabel fld (EncodeParams db '[fld ::: ty] x) where + fromLabel + = EncodeParams + $ fmap (\param -> SOP.K param :* Nil) + . toParam @db @(NullPG x) + +{- | +>>> import GHC.Generics as GHC +>>> :{ +data L = L {frst :: Int16, scnd :: Char} + deriving stock (GHC.Generic, Show) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +data R = R {thrd :: Bool, frth :: Bool} + deriving stock (GHC.Generic, Show) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) +instance IsPG (L,R) where + type PG (L,R) = 'PGcomposite '[ + "frst" ::: 'NotNull 'PGint2, + "scnd" ::: 'NotNull ('PGchar 1), + "thrd" ::: 'NotNull 'PGbool, + "frth" ::: 'NotNull 'PGbool] +instance ToPG db (L,R) where + toPG = rowParam $ + contramap fst genericRowParams + `appendParams` + contramap snd genericRowParams +:} +-} +genericRowParams + :: forall db row x xs. + ( SOP.IsRecord x xs + , SOP.AllZip (ToField db) row xs + ) + => EncodeParams db row x +genericRowParams + = EncodeParams + $ hctransverse (SOP.Proxy @(ToField db)) (toField @db) + . SOP.toRecord + +-- helper functions + +getOid :: LibPQ.Oid -> Word32 +getOid (LibPQ.Oid (CUInt oid)) = oid + +encodeArray :: Int32 -> Bool -> LibPQ.Oid -> [Int32] -> Encoding -> Encoding +encodeArray ndim nulls oid dimensions payload = mconcat + [ int4_int32 ndim + , if nulls then true4 else false4 + , int4_word32 (getOid oid) + , foldMap (\dimension -> int4_int32 dimension <> true4) dimensions + , payload ] + +dimArray + :: Functor m + => (forall b. (b -> a -> m b) -> b -> c -> m b) + -> (a -> m Encoding) -> c -> m Encoding +dimArray folder elementArray = folder step mempty + where + step builder element = (builder <>) <$> elementArray element + +null4, true4, false4 :: Encoding +null4 = int4_int32 (-1) +true4 = int4_word32 1 +false4 = int4_word32 0 + +sized :: Encoding -> Encoding +sized bs = int4_int32 (fromIntegral (builderLength bs)) <> bs + +hctransverse + :: (SOP.AllZip c ys xs, Applicative m) + => SOP.Proxy c + -> (forall y x. c y x => f x -> m (g y)) + -> NP f xs -> m (NP g ys) +hctransverse c f = \case + Nil -> pure Nil + x :* xs -> (:*) <$> f x <*> hctransverse c f xs + +hcfoldMapM + :: (Monoid r, Applicative m, SOP.All c xs) + => SOP.Proxy c + -> (forall x. c x => f x -> m r) + -> NP f xs -> m r +hcfoldMapM c f = \case + Nil -> pure mempty + x :* xs -> (<>) <$> f x <*> hcfoldMapM c f xs diff --git a/src/Squeal/PostgreSQL/Session/Exception.hs b/src/Squeal/PostgreSQL/Session/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Exception.hs @@ -0,0 +1,100 @@ +{-| +Module: Squeal.PostgreSQL.Session.Exception +Description: exceptions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +exceptions +-} + +{-# LANGUAGE + OverloadedStrings + , PatternSynonyms +#-} + +module Squeal.PostgreSQL.Session.Exception + ( SquealException (..) + , pattern UniqueViolation + , pattern CheckViolation + , pattern SerializationFailure + , pattern DeadlockDetected + , SQLState (..) + , LibPQ.ExecStatus (..) + , catchSqueal + , handleSqueal + , trySqueal + , throwSqueal + ) where + +import Control.Monad.Catch +import Data.ByteString (ByteString) +import Data.Text (Text) + +import qualified Database.PostgreSQL.LibPQ as LibPQ + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | the state of LibPQ +data SQLState = SQLState + { sqlExecStatus :: LibPQ.ExecStatus + , sqlStateCode :: ByteString + -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html + , sqlErrorMessage :: ByteString + } deriving (Eq, Show) + +-- | `Exception`s that can be thrown by Squeal. +data SquealException + = SQLException SQLState + -- ^ SQL exception state + | ConnectionException Text + -- ^ `Database.PostgreSQL.LibPQ` function connection exception + | DecodingException Text Text + -- ^ decoding exception function and error message + | ColumnsException Text LibPQ.Column + -- ^ unexpected number of columns + | RowsException Text LibPQ.Row LibPQ.Row + -- ^ too few rows, expected at least and actual number of rows + deriving (Eq, Show) +instance Exception SquealException + +-- | A pattern for unique violation exceptions. +pattern UniqueViolation :: ByteString -> SquealException +pattern UniqueViolation msg = + SQLException (SQLState LibPQ.FatalError "23505" msg) +-- | A pattern for check constraint violation exceptions. +pattern CheckViolation :: ByteString -> SquealException +pattern CheckViolation msg = + SQLException (SQLState LibPQ.FatalError "23514" msg) +-- | A pattern for serialization failure exceptions. +pattern SerializationFailure :: ByteString -> SquealException +pattern SerializationFailure msg = + SQLException (SQLState LibPQ.FatalError "40001" msg) +-- | A pattern for deadlock detection exceptions. +pattern DeadlockDetected :: ByteString -> SquealException +pattern DeadlockDetected msg = + SQLException (SQLState LibPQ.FatalError "40P01" msg) + +-- | Catch `SquealException`s. +catchSqueal + :: MonadCatch m + => m a + -> (SquealException -> m a) -- ^ handler + -> m a +catchSqueal = catch + +-- | Handle `SquealException`s. +handleSqueal + :: MonadCatch m + => (SquealException -> m a) -- ^ handler + -> m a -> m a +handleSqueal = handle + +-- | `Either` return a `SquealException` or a result. +trySqueal :: MonadCatch m => m a -> m (Either SquealException a) +trySqueal = try + +-- | Throw `SquealException`s. +throwSqueal :: MonadThrow m => SquealException -> m a +throwSqueal = throwM diff --git a/src/Squeal/PostgreSQL/Session/Indexed.hs b/src/Squeal/PostgreSQL/Session/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Indexed.hs @@ -0,0 +1,126 @@ +{-| +Module: Squeal.PostgreSQL.Session.Indexed +Description: indexed session monad +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +`Squeal.PostgreSQL.Indexed` provides an indexed monad transformer +class and a class extending it to run `Definition`s. +-} + +{-# LANGUAGE + DataKinds + , DefaultSignatures + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , PolyKinds + , MultiParamTypeClasses + , QuantifiedConstraints + , RankNTypes + , TypeApplications + , TypeFamilies + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Session.Indexed + ( IndexedMonadTrans (..) + , Indexed (..) + , IndexedMonadTransPQ (..) + , indexedDefine + ) where + +import Control.Category (Category (..)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans +import Data.Function ((&)) +import Prelude hiding (id, (.)) + +import Squeal.PostgreSQL.Definition + +{- | An [Atkey indexed monad] +(https://bentnib.org/paramnotions-jfp.pdf) +is a `Functor` [enriched category] +(https://ncatlab.org/nlab/show/enriched+category). +An indexed monad transformer transforms a `Monad` into an indexed monad, +and is a monad transformer when its source and target are the same, +enabling use of standard @do@ notation for endo-index operations. +-} +class + ( forall i j m. Monad m => Functor (t i j m) + , forall i m. Monad m => Monad (t i i m) + , forall i. MonadTrans (t i i) + ) => IndexedMonadTrans t where + + {-# MINIMAL pqJoin | pqBind #-} + + -- | indexed analog of `<*>` + pqAp + :: Monad m + => t i j m (x -> y) + -> t j k m x + -> t i k m y + pqAp tf tx = pqBind (<$> tx) tf + + -- | indexed analog of `join` + pqJoin + :: Monad m + => t i j m (t j k m y) + -> t i k m y + pqJoin t = t & pqBind id + + -- | indexed analog of `=<<` + pqBind + :: Monad m + => (x -> t j k m y) + -> t i j m x + -> t i k m y + pqBind f t = pqJoin (f <$> t) + + -- | indexed analog of flipped `>>` + pqThen + :: Monad m + => t j k m y + -> t i j m x + -> t i k m y + pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) + + -- | indexed analog of `<=<` + pqAndThen + :: Monad m + => (y -> t j k m z) + -> (x -> t i j m y) + -> x -> t i k m z + pqAndThen g f x = pqBind g (f x) + +{- | `Indexed` reshuffles the type parameters of an `IndexedMonadTrans`, +exposing its `Category` instance.-} +newtype Indexed t m r i j = Indexed {runIndexed :: t i j m r} +instance + ( IndexedMonadTrans t + , Monad m + , Monoid r + ) => Category (Indexed t m r) where + id = Indexed (pure mempty) + Indexed g . Indexed f = Indexed $ pqAp (fmap (<>) f) g + +{- | `IndexedMonadTransPQ` is a class for indexed monad transformers +that support running `Definition`s using `define` which acts functorially in effect. + +* @define id = return ()@ +* @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@ +-} +class IndexedMonadTrans pq => IndexedMonadTransPQ pq where + define :: MonadIO io => Definition db0 db1 -> pq db0 db1 io () + +{- | Run a pure SQL `Definition` functorially in effect + +* @indexedDefine id = id@ +* @indexedDefine (def1 >>> def2) = indexedDefine def1 >>> indexedDefine def2@ +-} +indexedDefine + :: (IndexedMonadTransPQ pq, MonadIO io) + => Definition db0 db1 -> Indexed pq io () db0 db1 +indexedDefine = Indexed . define diff --git a/src/Squeal/PostgreSQL/Session/Migration.hs b/src/Squeal/PostgreSQL/Session/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Migration.hs @@ -0,0 +1,456 @@ +{-| +Module: Squeal.PostgreSQL.Session.Migration +Description: migrations +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +This module defines a `Migration` type to safely +change the schema of your database over time. Let's see an example! + +First turn on some extensions. + +>>> :set -XDataKinds -XOverloadedLabels +>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators + +Next, let's define our `TableType`s. + +>>> :{ +type UsersTable = + '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ] +:} + +>>> :{ +type EmailsTable = + '[ "pk_emails" ::: 'PrimaryKey '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ] +:} + +Now we can define some `Migration`s to make our tables. + +`Migration`s are parameterized giving the option of a + +* pure one-way `Migration` `Definition` +* impure one-way `Migration` @(@`Indexed` `PQ` `IO`@)@ +* pure reversible `Migration` @(@`IsoQ` `Definition`@)@ +* impure reversible `Migration` @(@`IsoQ` @(@`Indexed` `PQ` `IO`@)@@)@ + +For this example, we'll use pure reversible `Migration`s. + +>>> :{ +let + makeUsers :: Migration (IsoQ Definition) + '["public" ::: '[]] + '["public" ::: '["users" ::: 'Table UsersTable]] + makeUsers = Migration "make users table" IsoQ + { up = createTable #users + ( serial `as` #id :* + notNullable text `as` #name ) + ( primaryKey #id `as` #pk_users ) + , down = dropTable #users + } +:} + +>>> :{ +let + makeEmails :: Migration (IsoQ Definition) + '["public" ::: '["users" ::: 'Table UsersTable]] + '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]] + makeEmails = Migration "make emails table" IsoQ + { up = createTable #emails + ( serial `as` #id :* + notNullable int `as` #user_id :* + nullable text `as` #email ) + ( primaryKey #id `as` #pk_emails :* + foreignKey #user_id #users #id + (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) + , down = dropTable #emails + } +:} + +Now that we have a couple migrations we can chain them together into a `Path`. + +>>> let migrations = makeUsers :>> makeEmails :>> Done + +Now run the migrations. + +>>> import Control.Monad.IO.Class +>>> :{ +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")) + & pqThen (migrateUp migrations) + & pqThen (liftIO (putStrLn "Rollback")) + & pqThen (migrateDown migrations) +:} +Migrate +Rollback + +We can also create a simple executable using `mainMigrateIso`. + +>>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" migrations + +>>> withArgs [] main +Invalid command: "". Use: +migrate to run all available migrations +rollback to rollback all available migrations +status to display migrations run and migrations left to run + +>>> withArgs ["status"] main +Migrations already run: + None +Migrations left to run: + - make users table + - make emails table + +>>> withArgs ["migrate"] main +Migrations already run: + - make users table + - make emails table +Migrations left to run: + None + +>>> withArgs ["rollback"] main +Migrations already run: + None +Migrations left to run: + - make users table + - make emails table + +In addition to enabling `Migration`s using pure SQL `Definition`s for +the `up` and `down` migrations, you can also perform impure `IO` actions +by using a `Migration`s over the `Indexed` `PQ` `IO` category. +-} + +{-# LANGUAGE + DataKinds + , DeriveGeneric + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , PolyKinds + , QuantifiedConstraints + , RankNTypes + , TypeApplications + , TypeOperators +#-} + +module Squeal.PostgreSQL.Session.Migration + ( -- * Migration + Migration (..) + , Migratory (..) + , migrate + , migrateUp + , migrateDown + , MigrationsTable + -- * Executable + , mainMigrate + , mainMigrateIso + -- * Re-export + , IsoQ (..) + ) where + +import Control.Category +import Control.Category.Free +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.List ((\\)) +import Data.Quiver +import Data.Quiver.Functor +import Data.Text (Text) +import Data.Time (UTCTime) +import Prelude hiding ((.), id) +import System.Environment + +import qualified Data.Text.IO as Text (putStrLn) +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Definition +import Squeal.PostgreSQL.Definition.Constraint +import Squeal.PostgreSQL.Definition.Table +import Squeal.PostgreSQL.Expression.Comparison +import Squeal.PostgreSQL.Expression.Default +import Squeal.PostgreSQL.Expression.Parameter +import Squeal.PostgreSQL.Expression.Time +import Squeal.PostgreSQL.Expression.Type +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Manipulation.Delete +import Squeal.PostgreSQL.Manipulation.Insert +import Squeal.PostgreSQL.Session +import Squeal.PostgreSQL.Session.Decode +import Squeal.PostgreSQL.Session.Encode +import Squeal.PostgreSQL.Session.Indexed +import Squeal.PostgreSQL.Session.Monad +import Squeal.PostgreSQL.Session.Result +import Squeal.PostgreSQL.Session.Statement +import Squeal.PostgreSQL.Session.Transaction.Unsafe +import Squeal.PostgreSQL.Query.From +import Squeal.PostgreSQL.Query.Select +import Squeal.PostgreSQL.Query.Table +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Type.Schema + +-- | A `Migration` consists of a name and a migration definition. +data Migration def db0 db1 = 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) + +{- | +A `Migratory` `Category` can run or +possibly rewind a `Path` of `Migration`s. +-} +class (Category def, Category run) => Migratory def run | def -> run where + {- | Run a `Path` of `Migration`s.-} + runMigrations :: Path (Migration def) db0 db1 -> run db0 db1 +-- | impure migrations +instance Migratory (Indexed PQ IO ()) (Indexed PQ IO ()) where + runMigrations path = Indexed . unsafePQ . transactionally_ $ do + define createMigrations + qtoMonoid upMigration path + where + upMigration step = do + executed <- do + result <- executeParams selectMigration (migrationName step) + ntuples (result :: Result UTCTime) + unless (executed == 1) $ do + _ <- unsafePQ . runIndexed $ migrationDef step + executeParams_ insertMigration (migrationName step) +-- | pure migrations +instance Migratory Definition (Indexed PQ IO ()) where + runMigrations = runMigrations . qmap (qmap ixDefine) +-- | impure rewinds +instance Migratory (OpQ (Indexed PQ IO ())) (OpQ (Indexed PQ IO ())) where + runMigrations path = OpQ . Indexed . unsafePQ . transactionally_ $ do + define createMigrations + qtoMonoid @FoldPath downMigration (reversePath path) + where + downMigration (OpQ step) = do + executed <- do + result <- executeParams selectMigration (migrationName step) + ntuples (result :: Result UTCTime) + unless (executed == 0) $ do + _ <- 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)) +-- | impure rewindable migrations +instance Migratory + (IsoQ (Indexed PQ IO ())) + (IsoQ (Indexed PQ IO ())) where + runMigrations path = IsoQ + (runMigrations (qmap (qmap up) path)) + (getOpQ (runMigrations (qmap (qmap (OpQ . down)) path))) +-- | pure rewindable migrations +instance Migratory (IsoQ Definition) (IsoQ (Indexed PQ IO ())) where + runMigrations = runMigrations . qmap (qmap (qmap ixDefine)) + +unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x +unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK + +-- | Run migrations. +migrate + :: Migratory def (Indexed PQ IO ()) + => Path (Migration def) db0 db1 + -> PQ db0 db1 IO () +migrate = runIndexed . runMigrations + +-- | Run rewindable migrations. +migrateUp + :: Migratory def (IsoQ (Indexed PQ IO ())) + => Path (Migration def) db0 db1 + -> PQ db0 db1 IO () +migrateUp = runIndexed . up . runMigrations + +-- | Rewind migrations. +migrateDown + :: Migratory def (IsoQ (Indexed PQ IO ())) + => Path (Migration def) db0 db1 + -> PQ db1 db0 IO () +migrateDown = runIndexed . down . runMigrations + +ixDefine :: Definition db0 db1 -> Indexed PQ IO () db0 db1 +ixDefine = indexedDefine + +-- | The `TableType` for a Squeal migration. +type MigrationsTable = + '[ "migrations_unique_name" ::: 'Unique '["name"]] :=> + '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext + , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz + ] + +data MigrationRow = + MigrationRow { name :: Text + , executed_at :: UTCTime } + deriving (GHC.Generic, Show) + +instance SOP.Generic MigrationRow +instance SOP.HasDatatypeInfo MigrationRow + +type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable] +type MigrationsSchemas = Public MigrationsSchema + +-- | Creates a `MigrationsTable` if it does not already exist. +createMigrations :: Definition MigrationsSchemas MigrationsSchemas +createMigrations = + createTableIfNotExists #schema_migrations + ( (text & notNullable) `as` #name :* + (timestampWithTimeZone & notNullable & default_ currentTimestamp) + `as` #executed_at ) + ( unique #name `as` #migrations_unique_name ) + +-- | Inserts a `Migration` into the `MigrationsTable`, returning +-- the time at which it was inserted. +insertMigration :: Statement MigrationsSchemas Text () +insertMigration = Manipulation aParam genericRow $ + insertInto_ #schema_migrations $ + Values_ (Set (param @1) `as` #name :* Default `as` #executed_at) + +-- | Deletes a `Migration` from the `MigrationsTable`, returning +-- the time at which it was inserted. +deleteMigration :: Statement MigrationsSchemas Text () +deleteMigration = Manipulation aParam genericRow $ + deleteFrom_ #schema_migrations (#name .== param @1) + +-- | Selects a `Migration` from the `MigrationsTable`, returning +-- the time at which it was inserted. +selectMigration :: Statement MigrationsSchemas Text UTCTime +selectMigration = Query aParam #executed_at $ + select_ #executed_at + $ from (table (#schema_migrations)) + & where_ (#name .== param @1) + +selectMigrations :: Statement MigrationsSchemas () MigrationRow +selectMigrations = query $ select Star (from (table #schema_migrations)) + +{- | `mainMigrate` creates a simple executable +from a connection string and a `Path` of `Migration`s. -} +mainMigrate + :: Migratory p (Indexed PQ IO ()) + => ByteString + -- ^ connection string + -> Path (Migration p) db0 db1 + -- ^ migrations + -> IO () +mainMigrate connectTo migrations = do + command <- getArgs + performCommand command + + where + + performCommand :: [String] -> IO () + performCommand = \case + ["status"] -> withConnection connectTo $ + suppressNotices >> migrateStatus + ["migrate"] -> withConnection connectTo $ + suppressNotices + & pqThen (runIndexed (runMigrations migrations)) + & pqThen migrateStatus + args -> displayUsage args + + migrateStatus :: PQ schema schema IO () + migrateStatus = unsafePQ $ do + runNames <- getRunMigrationNames + let names = qtoList migrationName migrations + unrunNames = names \\ runNames + liftIO $ displayRunned runNames >> displayUnrunned unrunNames + + suppressNotices :: PQ schema schema IO () + suppressNotices = manipulate_ $ + UnsafeManipulation "SET client_min_messages TO WARNING;" + + displayUsage :: [String] -> IO () + displayUsage args = do + putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:" + putStrLn "migrate to run all available migrations" + putStrLn "rollback to rollback all available migrations" + +{- | `mainMigrateIso` creates a simple executable +from a connection string and a `Path` of `Migration` `IsoQ`s. -} +mainMigrateIso + :: Migratory (IsoQ def) (IsoQ (Indexed PQ IO ())) + => ByteString + -- ^ connection string + -> Path (Migration (IsoQ def)) db0 db1 + -- ^ migrations + -> IO () +mainMigrateIso connectTo migrations = performCommand =<< getArgs + + where + + performCommand :: [String] -> IO () + performCommand = \case + ["status"] -> withConnection connectTo $ + suppressNotices >> migrateStatus + ["migrate"] -> withConnection connectTo $ + suppressNotices + & pqThen (migrateUp migrations) + & pqThen migrateStatus + ["rollback"] -> withConnection connectTo $ + suppressNotices + & pqThen (migrateDown migrations) + & pqThen migrateStatus + args -> displayUsage args + + migrateStatus :: PQ schema schema IO () + migrateStatus = unsafePQ $ do + runNames <- getRunMigrationNames + let names = qtoList migrationName migrations + unrunNames = names \\ runNames + liftIO $ displayRunned runNames >> displayUnrunned unrunNames + + suppressNotices :: PQ schema schema IO () + suppressNotices = manipulate_ $ + UnsafeManipulation "SET client_min_messages TO WARNING;" + + displayUsage :: [String] -> IO () + displayUsage args = do + putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:" + putStrLn "migrate to run all available migrations" + putStrLn "rollback to rollback all available migrations" + putStrLn "status to display migrations run and migrations left to run" + +getRunMigrationNames :: PQ db0 db0 IO [Text] +getRunMigrationNames = + fmap name <$> + (unsafePQ (define createMigrations + & pqThen (execute selectMigrations)) >>= getRows) + +displayListOfNames :: [Text] -> IO () +displayListOfNames [] = Text.putStrLn " None" +displayListOfNames xs = + let singleName n = Text.putStrLn $ " - " <> n + in traverse_ singleName xs + +displayUnrunned :: [Text] -> IO () +displayUnrunned unrunned = + Text.putStrLn "Migrations left to run:" + >> displayListOfNames unrunned + +displayRunned :: [Text] -> IO () +displayRunned runned = + Text.putStrLn "Migrations already run:" + >> displayListOfNames runned diff --git a/src/Squeal/PostgreSQL/Session/Monad.hs b/src/Squeal/PostgreSQL/Session/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Monad.hs @@ -0,0 +1,765 @@ +{-| +Module: Squeal.PostgreSQL.Session.Monad +Description: session monad +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Run `Squeal.PostgreSQL.Session.Statement`s in the mtl-style +typeclass `MonadPQ`. +-} +{-# LANGUAGE + DataKinds + , DefaultSignatures + , DeriveFunctor + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , MultiParamTypeClasses + , PolyKinds + , QuantifiedConstraints + , RankNTypes + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Session.Monad + ( -- * MonadPQ + MonadPQ (..) + -- * Manipulate + , manipulateParams + , manipulateParams_ + , manipulate + , manipulate_ + -- * Run Query + , runQueryParams + , runQuery + -- * Prepared + , executePrepared + , executePrepared_ + , traversePrepared + , forPrepared + , traversePrepared_ + , forPrepared_ + , preparedFor + ) where + +import Control.Category (Category (..)) +import Control.Monad +import Control.Monad.Morph +import Data.Foldable +import Data.Profunctor.Traversing +import Data.Traversable +import Prelude hiding (id, (.)) + +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Session.Decode +import Squeal.PostgreSQL.Session.Encode +import Squeal.PostgreSQL.Session.Result +import Squeal.PostgreSQL.Session.Statement +import Squeal.PostgreSQL.Query + +-- For `MonadPQ` transformer instances +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict +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. +-} +class Monad pq => MonadPQ db pq | pq -> db where + + {- | + `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 + -- ^ query or manipulation + -> x + -- ^ parameters + -> pq (Result y) + default executeParams + :: (MonadTrans t, MonadPQ db m, pq ~ t m) + => 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`. + + >>> 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 () + -- ^ query or manipulation + -> x + -- ^ parameters + -> pq () + executeParams_ statement params = void $ executeParams statement params + + {- | `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 + -- ^ query or manipulation + -> pq (Result y) + execute statement = executeParams 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 () () + -- ^ query or manipulation + -> pq () + execute_ = void . execute + + {- | + `prepare` creates a `Prepared` statement. When `prepare` is executed, + the specified `Statement` is parsed, analyzed, and rewritten. + + >>> import Data.Int (Int32, Int64) + >>> import Data.Monoid (Sum(Sum)) + >>> :{ + 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 + prepared <- prepare sumOf + result <- runPrepared prepared (2,2) + deallocate prepared + firstRow result + :} + Just (Sum {getSum = 4}) + -} + prepare + :: Statement db x y + -- ^ query or manipulation + -> pq (Prepared pq x (Result y)) + default prepare + :: (MonadTrans t, MonadPQ db m, pq ~ t m) + => Statement db x y + -- ^ query or manipulation + -> pq (Prepared pq x (Result y)) + prepare statement = do + prepared <- lift $ prepare statement + return $ Prepared + (lift . runPrepared prepared) + (lift (deallocate prepared)) + + {- | + `prepare_` creates a `Prepared` statement. When `prepare_` is executed, + the specified `Statement` is parsed, analyzed, and rewritten. + + >>> type Column = 'NoDef :=> 'NotNull 'PGint4 + >>> type Columns = '["col1" ::: Column, "col2" ::: Column] + >>> 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 + session :: PQ DB DB IO () + session = do + prepared <- prepare_ insertion + runPrepared prepared (2,2) + deallocate prepared + teardown :: Definition DB (Public '[]) + teardown = dropTable #tab + in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ + define setup + & pqThen session + & pqThen (define teardown) + :} + -} + prepare_ + :: Statement db x () + -- ^ query or manipulation + -> pq (Prepared pq x ()) + prepare_ = fmap void . prepare + +{- | +* `prepare` a statement +* transforming its inputs and outputs with an optic, + run the `Prepared` statement +* deallocate the `Prepared` statement + +>>> :type preparedFor traverse' +preparedFor traverse' + :: (MonadPQ db pq, Traversable f) => + Statement db a b -> f a -> pq (f (Result b)) +-} +preparedFor + :: MonadPQ db pq + => (Prepared pq a (Result b) -> Prepared pq s t) + -- ^ transform the input and output + -> Statement db a b -- ^ query or manipulation + -> s -> pq t +preparedFor optic statement x' = do + prepared <- prepare statement + y' <- runPrepared (optic prepared) x' + deallocate prepared + return y' + +{- | +`executePrepared` runs a `Statement` on a `Traversable` +container by first preparing the statement, then running the prepared +statement on each element. + +>>> import Data.Int (Int32, Int64) +>>> import Data.Monoid (Sum(Sum)) +>>> :{ +let + sumOf :: Statement db (Int32, Int32) (Sum Int32) + sumOf = query $ values_ $ + ( param @1 @('NotNull 'PGint4) + + param @2 @('NotNull 'PGint4) + ) `as` #getSum +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do + results <- executePrepared sumOf [(2,2),(3,3),(4,4)] + traverse firstRow results +:} +[Just (Sum {getSum = 4}),Just (Sum {getSum = 6}),Just (Sum {getSum = 8})] +-} +executePrepared + :: (MonadPQ db pq, Traversable list) + => Statement db x y + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq (list (Result y)) +executePrepared = preparedFor traverse' + +{- | +`executePrepared_` runs a returning-free `Statement` on a `Foldable` +container by first preparing the statement, then running the prepared +statement on each element. + +>>> type Column = 'NoDef :=> 'NotNull 'PGint4 +>>> type Columns = '["col1" ::: Column, "col2" ::: Column] +>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] +>>> type DB = Public Schema +>>> import Data.Int(Int32) +>>> :{ +let + insertion :: Statement DB (Int32, Int32) () + insertion = manipulation $ insertInto_ #tab $ Values_ $ + Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* + Set (param @2 @('NotNull 'PGint4)) `as` #col2 + setup :: Definition (Public '[]) DB + setup = createTable #tab + ( notNullable int4 `as` #col1 :* + notNullable int4 `as` #col2 + ) Nil + teardown :: Definition DB (Public '[]) + teardown = dropTable #tab +in + withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ + define setup + & pqThen (executePrepared_ insertion [(2,2),(3,3),(4,4)]) + & pqThen (define teardown) +:} +-} +executePrepared_ + :: (MonadPQ db pq, Foldable list) + => Statement db x () + -- ^ query or manipulation + -> list x + -- ^ list of parameters + -> pq () +executePrepared_ = preparedFor (wander traverse_) + +{- | +`manipulateParams` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`. + +>>> type Column = 'NoDef :=> 'NotNull 'PGint4 +>>> 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 + , GenericParams db params x xs + , GenericRow row y ys + ) => Manipulation '[] db params row + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, + -- `Squeal.PostgreSQL.Manipulation.Update.update`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends + -> x -> pq (Result y) +manipulateParams = executeParams . manipulation + +{- | +`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 + , GenericParams db params x xs + ) => Manipulation '[] db params '[] + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`, + -- `Squeal.PostgreSQL.Manipulation.Update.update_`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends + -> x -> pq () +manipulateParams_ = executeParams_ . manipulation + +{- | +`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) + => Manipulation '[] db '[] row + -> pq (Result y) +manipulate = execute . manipulation + +{- | +`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 + => Manipulation '[] db '[] '[] + -> pq () +manipulate_ = execute_ . manipulation + +{- | +`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 + , GenericParams db params x xs + , GenericRow row y ys + ) => Query '[] '[] db params row + -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends + -> x -> pq (Result y) +runQueryParams = executeParams . query + +{- | +`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, GenericRow row y ys) + => Query '[] '[] db '[] row + -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends + -> pq (Result y) +runQuery = execute . query + +{- | +`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 + , GenericParams db params x xs + , GenericRow row y ys + , Traversable list ) + => Manipulation '[] db params row + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, + -- `Squeal.PostgreSQL.Manipulation.Update.update`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends + -> list x -> pq (list (Result y)) +traversePrepared = executePrepared . manipulation + +{- | +`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 + , GenericParams db params x xs + , GenericRow row y ys + , Traversable list ) + => list x + -> Manipulation '[] db params row + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, + -- `Squeal.PostgreSQL.Manipulation.Update.update`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends + -> pq (list (Result y)) +forPrepared = flip traversePrepared + +{- | +`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 + , GenericParams db params x xs + , Foldable list ) + => Manipulation '[] db params '[] + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`, + -- `Squeal.PostgreSQL.Manipulation.Update.update_`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends + -> list x -> pq () +traversePrepared_ = executePrepared_ . manipulation + +{- | +`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 + , GenericParams db params x xs + , Foldable list ) + => list x + -> Manipulation '[] db params '[] + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`, + -- `Squeal.PostgreSQL.Manipulation.Update.update_`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends + -> pq () +forPrepared_ = flip traversePrepared_ + +instance MonadPQ db m => MonadPQ db (IdentityT m) +instance MonadPQ db m => MonadPQ db (ReaderT r m) +instance MonadPQ db m => MonadPQ db (Strict.StateT s m) +instance MonadPQ db m => MonadPQ db (Lazy.StateT s m) +instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.WriterT w m) +instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.WriterT w m) +instance MonadPQ db m => MonadPQ db (MaybeT m) +instance MonadPQ db m => MonadPQ db (ExceptT e m) +instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.RWST r w s m) +instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.RWST r w s m) +instance MonadPQ db m => MonadPQ db (ContT r m) diff --git a/src/Squeal/PostgreSQL/Session/Oid.hs b/src/Squeal/PostgreSQL/Session/Oid.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Oid.hs @@ -0,0 +1,234 @@ +{-| +Module: Squeal.PostgreSQL.Session.Oid +Description: object identifiers +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Object identifiers are used internally by PostgreSQL as +primary keys. They are needed to correctly encode +statement parameters. +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , PolyKinds + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Session.Oid + ( -- * Oids + LibPQ.Oid + , OidOf (..) + , OidOfArray (..) + , OidOfNull (..) + , OidOfField (..) + ) where + +import Control.Monad (when) +import Control.Monad.Catch (throwM) +import Control.Monad.Reader +import Data.String +import GHC.TypeLits +import PostgreSQL.Binary.Decoding (valueParser, int) + +import qualified Data.ByteString as ByteString +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Session.Exception +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | The `LibPQ.Oid` of a `PGType` +-- +-- >>> :set -XTypeApplications +-- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" +-- >>> runReaderT (oidOf @'[] @'PGbool) conn +-- Oid 16 +-- +-- >>> finish conn +class OidOf (db :: SchemasType) (pg :: PGType) where + oidOf :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +-- | The `LibPQ.Oid` of an array +class OidOfArray (db :: SchemasType) (pg :: PGType) where + oidOfArray :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +instance OidOfArray db pg => OidOf db ('PGvararray (null pg)) where + oidOf = oidOfArray @db @pg +instance OidOfArray db pg => OidOf db ('PGfixarray dims (null pg)) where + oidOf = oidOfArray @db @pg +-- | The `LibPQ.Oid` of a `NullType` +class OidOfNull (db :: SchemasType) (ty :: NullType) where + oidOfNull :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +instance OidOf db pg => OidOfNull db (null pg) where + oidOfNull = oidOf @db @pg +-- | The `LibPQ.Oid` of a field +class OidOfField (db :: SchemasType) (field :: (Symbol, NullType)) where + oidOfField :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +instance OidOfNull db ty => OidOfField db (fld ::: ty) where + oidOfField = oidOfNull @db @ty + +instance OidOf db 'PGbool where oidOf = pure $ LibPQ.Oid 16 +instance OidOfArray db 'PGbool where oidOfArray = pure $ LibPQ.Oid 1000 +instance OidOf db 'PGint2 where oidOf = pure $ LibPQ.Oid 21 +instance OidOfArray db 'PGint2 where oidOfArray = pure $ LibPQ.Oid 1005 +instance OidOf db 'PGint4 where oidOf = pure $ LibPQ.Oid 23 +instance OidOfArray db 'PGint4 where oidOfArray = pure $ LibPQ.Oid 1007 +instance OidOf db 'PGint8 where oidOf = pure $ LibPQ.Oid 20 +instance OidOfArray db 'PGint8 where oidOfArray = pure $ LibPQ.Oid 1016 +instance OidOf db 'PGnumeric where oidOf = pure $ LibPQ.Oid 1700 +instance OidOfArray db 'PGnumeric where oidOfArray = pure $ LibPQ.Oid 1231 +instance OidOf db 'PGfloat4 where oidOf = pure $ LibPQ.Oid 700 +instance OidOfArray db 'PGfloat4 where oidOfArray = pure $ LibPQ.Oid 1021 +instance OidOf db 'PGfloat8 where oidOf = pure $ LibPQ.Oid 701 +instance OidOfArray db 'PGfloat8 where oidOfArray = pure $ LibPQ.Oid 1022 +instance OidOf db 'PGmoney where oidOf = pure $ LibPQ.Oid 790 +instance OidOfArray db 'PGmoney where oidOfArray = pure $ LibPQ.Oid 791 +instance OidOf db ('PGchar n) where oidOf = pure $ LibPQ.Oid 18 +instance OidOfArray db ('PGchar n) where oidOfArray = pure $ LibPQ.Oid 1002 +instance OidOf db ('PGvarchar n) where oidOf = pure $ LibPQ.Oid 1043 +instance OidOfArray db ('PGvarchar n) where oidOfArray = pure $ LibPQ.Oid 1015 +instance OidOf db 'PGtext where oidOf = pure $ LibPQ.Oid 25 +instance OidOfArray db 'PGtext where oidOfArray = pure $ LibPQ.Oid 1009 +instance OidOf db 'PGbytea where oidOf = pure $ LibPQ.Oid 17 +instance OidOfArray db 'PGbytea where oidOfArray = pure $ LibPQ.Oid 1001 +instance OidOf db 'PGtimestamp where oidOf = pure $ LibPQ.Oid 1114 +instance OidOfArray db 'PGtimestamp where oidOfArray = pure $ LibPQ.Oid 1115 +instance OidOf db 'PGtimestamptz where oidOf = pure $ LibPQ.Oid 1184 +instance OidOfArray db 'PGtimestamptz where oidOfArray = pure $ LibPQ.Oid 1185 +instance OidOf db 'PGdate where oidOf = pure $ LibPQ.Oid 1082 +instance OidOfArray db 'PGdate where oidOfArray = pure $ LibPQ.Oid 1182 +instance OidOf db 'PGtime where oidOf = pure $ LibPQ.Oid 1083 +instance OidOfArray db 'PGtime where oidOfArray = pure $ LibPQ.Oid 1183 +instance OidOf db 'PGtimetz where oidOf = pure $ LibPQ.Oid 1266 +instance OidOfArray db 'PGtimetz where oidOfArray = pure $ LibPQ.Oid 1270 +instance OidOf db 'PGinterval where oidOf = pure $ LibPQ.Oid 1186 +instance OidOfArray db 'PGinterval where oidOfArray = pure $ LibPQ.Oid 1187 +instance OidOf db 'PGuuid where oidOf = pure $ LibPQ.Oid 2950 +instance OidOfArray db 'PGuuid where oidOfArray = pure $ LibPQ.Oid 2951 +instance OidOf db 'PGinet where oidOf = pure $ LibPQ.Oid 869 +instance OidOfArray db 'PGinet where oidOfArray = pure $ LibPQ.Oid 1041 +instance OidOf db 'PGjson where oidOf = pure $ LibPQ.Oid 114 +instance OidOfArray db 'PGjson where oidOfArray = pure $ LibPQ.Oid 199 +instance OidOf db 'PGjsonb where oidOf = pure $ LibPQ.Oid 3802 +instance OidOfArray db 'PGjsonb where oidOfArray = pure $ LibPQ.Oid 3807 +instance OidOf db 'PGtsvector where oidOf = pure $ LibPQ.Oid 3614 +instance OidOfArray db 'PGtsvector where oidOfArray = pure $ LibPQ.Oid 3643 +instance OidOf db 'PGtsquery where oidOf = pure $ LibPQ.Oid 3615 +instance OidOfArray db 'PGtsquery where oidOfArray = pure $ LibPQ.Oid 3645 +instance OidOf db 'PGoid where oidOf = pure $ LibPQ.Oid 26 +instance OidOfArray db 'PGoid where oidOfArray = pure $ LibPQ.Oid 1028 +instance OidOf db ('PGrange 'PGint4) where oidOf = pure $ LibPQ.Oid 3904 +instance OidOfArray db ('PGrange 'PGint4) where oidOfArray = pure $ LibPQ.Oid 3905 +instance OidOf db ('PGrange 'PGint8) where oidOf = pure $ LibPQ.Oid 3926 +instance OidOfArray db ('PGrange 'PGint8) where oidOfArray = pure $ LibPQ.Oid 3927 +instance OidOf db ('PGrange 'PGnumeric) where oidOf = pure $ LibPQ.Oid 3906 +instance OidOfArray db ('PGrange 'PGnumeric) where oidOfArray = pure $ LibPQ.Oid 3907 +instance OidOf db ('PGrange 'PGtimestamp) where oidOf = pure $ LibPQ.Oid 3908 +instance OidOfArray db ('PGrange 'PGtimestamp) where oidOfArray = pure $ LibPQ.Oid 3909 +instance OidOf db ('PGrange 'PGtimestamptz) where oidOf = pure $ LibPQ.Oid 3910 +instance OidOfArray db ('PGrange 'PGtimestamptz) where oidOfArray = pure $ LibPQ.Oid 3911 +instance OidOf db ('PGrange 'PGdate) where oidOf = pure $ LibPQ.Oid 3912 +instance OidOfArray db ('PGrange 'PGdate) where oidOfArray = pure $ LibPQ.Oid 3913 +instance + ( KnownSymbol sch + , KnownSymbol td + , rels ~ DbRelations db + , FindQualified "no relation found with row:" rels row ~ '(sch,td) + ) => OidOf db ('PGcomposite row) where + oidOf = oidOfTypedef @sch @td +instance + ( KnownSymbol sch + , KnownSymbol td + , rels ~ DbRelations db + , FindQualified "no relation found with row:" rels row ~ '(sch,td) + ) => OidOfArray db ('PGcomposite row) where + oidOfArray = oidOfArrayTypedef @sch @td +instance + ( enums ~ DbEnums db + , FindQualified "no enum found with labels:" enums labels ~ '(sch,td) + , KnownSymbol sch + , KnownSymbol td + ) => OidOf db ('PGenum labels) where + oidOf = oidOfTypedef @sch @td +instance + ( enums ~ DbEnums db + , FindQualified "no enum found with labels:" enums labels ~ '(sch,td) + , KnownSymbol sch + , KnownSymbol td + ) => OidOfArray db ('PGenum labels) where + oidOfArray = oidOfArrayTypedef @sch @td + +oidOfTypedef + :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty) + => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +oidOfTypedef = ReaderT $ \(SOP.K conn) -> do + resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary + case resultMaybe of + Nothing -> throwM $ ConnectionException oidErr + Just result -> do + numRows <- LibPQ.ntuples result + when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows + valueMaybe <- LibPQ.getvalue result 0 0 + case valueMaybe of + Nothing -> throwM $ ConnectionException oidErr + Just value -> case valueParser int value of + Left err -> throwM $ DecodingException oidErr err + Right oid -> return $ LibPQ.Oid oid + where + tyVal = symbolVal (SOP.Proxy @ty) + schVal = symbolVal (SOP.Proxy @sch) + oidErr = "oidOfTypedef " <> fromString (schVal <> "." <> tyVal) + q = ByteString.intercalate " " + [ "SELECT pg_type.oid" + , "FROM pg_type" + , "INNER JOIN pg_namespace" + , "ON pg_type.typnamespace = pg_namespace.oid" + , "WHERE pg_type.typname = " + , "\'" <> fromString tyVal <> "\'" + , "AND pg_namespace.nspname = " + , "\'" <> fromString schVal <> "\'" + , ";" ] + +oidOfArrayTypedef + :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty) + => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid +oidOfArrayTypedef = ReaderT $ \(SOP.K conn) -> do + resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary + case resultMaybe of + Nothing -> throwM $ ConnectionException oidErr + Just result -> do + numRows <- LibPQ.ntuples result + when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows + valueMaybe <- LibPQ.getvalue result 0 0 + case valueMaybe of + Nothing -> throwM $ ConnectionException oidErr + Just value -> case valueParser int value of + Left err -> throwM $ DecodingException oidErr err + Right oid -> return $ LibPQ.Oid oid + where + tyVal = symbolVal (SOP.Proxy @ty) + schVal = symbolVal (SOP.Proxy @sch) + oidErr = "oidOfArrayTypedef " <> fromString (schVal <> "." <> tyVal) + q = ByteString.intercalate " " + [ "SELECT pg_type.typelem" + , "FROM pg_type" + , "INNER JOIN pg_namespace" + , "ON pg_type.typnamespace = pg_namespace.oid" + , "WHERE pg_type.typname = " + , "\'" <> fromString tyVal <> "\'" + , "AND pg_namespace.nspname = " + , "\'" <> fromString schVal <> "\'" + , ";" ] diff --git a/src/Squeal/PostgreSQL/Session/Pool.hs b/src/Squeal/PostgreSQL/Session/Pool.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Pool.hs @@ -0,0 +1,138 @@ +{-| +Module: Squeal.PostgreSQL.Pool +Description: connection pools +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Connection pools. + +Typical use case would be to create your pool using `createConnectionPool` +and run anything that requires the pool connection with `usingConnectionPool`. + +Here's a simplified example: + +>>> import Squeal.PostgreSQL + +>>> :{ +do + let + 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 qry + Just (Only a) <- firstRow result + return a + destroyConnectionPool pool + putChar chr +:} +a +-} + +{-# LANGUAGE + CPP + , DeriveFunctor + , FlexibleContexts + , FlexibleInstances + , InstanceSigs + , MultiParamTypeClasses + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , TypeFamilies + , DataKinds + , PolyKinds + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Session.Pool + ( -- * Pool + Pool + , createConnectionPool + , usingConnectionPool + , destroyConnectionPool + ) where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.ByteString +import Data.Time +import Data.Pool + +import Squeal.PostgreSQL.Type.Schema +import Squeal.PostgreSQL.Session (PQ (..)) +import Squeal.PostgreSQL.Session.Connection + +-- | Create a striped pool of connections. +-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyConnectionPool` when you're done with the pool so that the connections are freed up as soon as possible. +createConnectionPool + :: forall (db :: SchemasType) io. MonadIO io + => ByteString + -- ^ The passed string can be empty to use all default parameters, or it can + -- contain one or more parameter settings separated by whitespace. + -- Each parameter setting is in the form keyword = value. Spaces around the equal + -- sign are optional. To write an empty value or a value containing spaces, + -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and + -- backslashes within the value must be escaped with a backslash, i.e., ' and \. + -> Int + -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1. + -> NominalDiffTime + -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds. + -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals. + -> Int + -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1. + -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available. + -> io (Pool (K Connection db)) +createConnectionPool conninfo stripes idle maxResrc = +#if MIN_VERSION_resource_pool(0,4,0) + liftIO . newPool $ setNumStripes + (Just stripes) + (defaultPoolConfig (connectdb conninfo) finish (realToFrac idle) maxResrc) +#else + liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc +#endif + +{-| +Temporarily take a connection from a `Pool`, perform an action with it, +and return it to the pool afterwards. + +If the pool has an idle connection available, it is used immediately. +Otherwise, if the maximum number of connections has not yet been reached, +a new connection is created and used. +If the maximum number of connections has been reached, this function blocks +until a connection becomes available. +-} +usingConnectionPool + :: (MonadIO io, MonadMask io) + => Pool (K Connection db) -- ^ pool + -> PQ db db io x -- ^ session + -> io x +usingConnectionPool pool (PQ session) = mask $ \restore -> do + (conn, local) <- liftIO $ takeResource pool + ret <- restore (session conn) `onException` + liftIO (destroyResource pool local conn) + liftIO $ putResource local conn + return $ unK ret + +{- | +Destroy all connections in all stripes in the pool. +Note that this will ignore any exceptions in the destroy function. + +This function is useful when you detect that all connections +in the pool are broken. For example after a database has been +restarted all connections opened before the restart will be broken. +In that case it's better to close those connections so that +`usingConnectionPool` won't take a broken connection from the pool +but will open a new connection instead. + +Another use-case for this function is that when you know you are done +with the pool you can destroy all idle connections immediately +instead of waiting on the garbage collector to destroy them, +thus freeing up those connections sooner. +-} +destroyConnectionPool + :: MonadIO io + => Pool (K Connection db) -- ^ pool + -> io () +destroyConnectionPool = liftIO . destroyAllResources diff --git a/src/Squeal/PostgreSQL/Session/Result.hs b/src/Squeal/PostgreSQL/Session/Result.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Result.hs @@ -0,0 +1,223 @@ +{-| +Module: Squeal.PostgreSQL.Session.Result +Description: results +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Get values from a `Result`. +-} + +{-# LANGUAGE + FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , OverloadedStrings + , ScopedTypeVariables + , TypeApplications + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Session.Result + ( Result (..) + , MonadResult (..) + , liftResult + , nextRow + ) where + +import Control.Exception (throw) +import Control.Monad (when, (<=<)) +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Traversable (for) +import Text.Read (readMaybe) + +import 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 executing +`Squeal.PostgreSQL.Session.Statement`s +in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. + +They contain an underlying `LibPQ.Result` +and a `DecodeRow`. +-} +data Result y where + Result + :: SOP.SListI row + => DecodeRow row y + -> LibPQ.Result + -> Result y +instance Functor Result where + fmap f (Result decode result) = Result (fmap f decode) result + +{- | A `MonadResult` operation extracts values +from the `Result` of a `Squeal.PostgreSQL.Session.Monad.MonadPQ` operation. +There is no need to define instances of `MonadResult`. +An instance of `MonadIO` implies an instance of `MonadResult`. +However, the constraint `MonadResult` +does not imply the constraint `MonadIO`. +-} +class Monad m => MonadResult m where + -- | Get a row corresponding to a given row number from a `LibPQ.Result`, + -- throwing an exception if the row number is out of bounds. + getRow :: LibPQ.Row -> Result y -> m y + -- | Get all rows from a `LibPQ.Result`. + getRows :: Result y -> m [y] + -- | Get the first row if possible from a `LibPQ.Result`. + firstRow :: Result y -> m (Maybe y) + -- | Returns the number of rows (tuples) in the query result. + ntuples :: Result y -> m LibPQ.Row + -- | Returns the number of columns (fields) in the query result. + nfields :: Result y -> m LibPQ.Column + {- | + Returns the command status tag from the SQL command + that generated the `Result`. + Commonly this is just the name of the command, + but it might include additional data such as the number of rows processed. + -} + cmdStatus :: Result y -> m Text + {- | + Returns the number of rows affected by the SQL command. + This function returns `Just` the number of + rows affected by the SQL statement that generated the `Result`. + This function can only be used following the execution of a + SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH, + or COPY statement,or an EXECUTE of a prepared query that + contains an INSERT, UPDATE, or DELETE statement. + If the command that generated the PGresult was anything else, + `cmdTuples` returns `Nothing`. + -} + cmdTuples :: Result y -> m (Maybe LibPQ.Row) + -- | Returns the result status of the command. + resultStatus :: Result y -> m LibPQ.ExecStatus + -- | Check if a `Result`'s status is either `LibPQ.CommandOk` + -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`. + okResult :: Result y -> m () + -- | Returns the error message most recently generated by an operation + -- on the connection. + resultErrorMessage :: Result y -> m (Maybe ByteString) + -- | Returns the error code most recently generated by an operation + -- on the connection. + -- + -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html + resultErrorCode :: Result y -> m (Maybe ByteString) + +instance (Monad io, MonadIO io) => MonadResult io where + getRow r (Result decode result) = liftIO $ do + numRows <- LibPQ.ntuples result + numCols <- LibPQ.nfields result + when (numRows < r) $ throw $ RowsException "getRow" r numRows + row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] + case SOP.fromList row' of + Nothing -> throw $ ColumnsException "getRow" numCols + Just row -> case execDecodeRow decode row of + Left parseError -> throw $ DecodingException "getRow" parseError + Right y -> return y + + getRows (Result decode result) = liftIO $ do + numCols <- LibPQ.nfields result + numRows <- LibPQ.ntuples result + for [0 .. numRows - 1] $ \ r -> do + row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] + case SOP.fromList row' of + Nothing -> throw $ ColumnsException "getRows" numCols + Just row -> case execDecodeRow decode row of + Left parseError -> throw $ DecodingException "getRows" parseError + Right y -> return y + + firstRow (Result decode result) = liftIO $ do + numRows <- LibPQ.ntuples result + numCols <- LibPQ.nfields result + if numRows <= 0 then return Nothing else do + row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1] + case SOP.fromList row' of + Nothing -> throw $ ColumnsException "firstRow" numCols + Just row -> case execDecodeRow decode row of + Left parseError -> throw $ DecodingException "firstRow" parseError + Right y -> return $ Just y + + ntuples = liftResult LibPQ.ntuples + + nfields = liftResult LibPQ.nfields + + resultStatus = liftResult LibPQ.resultStatus + + cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus) + where + getCmdStatus = \case + Nothing -> throwM $ ConnectionException "LibPQ.cmdStatus" + Just bytes -> return $ Text.decodeUtf8 bytes + + cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples) + where + getCmdTuples = \case + Nothing -> throwM $ ConnectionException "LibPQ.cmdTuples" + Just bytes -> return $ + if ByteString.null bytes + then Nothing + else fromInteger <$> readMaybe (Char8.unpack bytes) + + okResult = liftResult okResult_ + + resultErrorMessage = liftResult LibPQ.resultErrorMessage + + resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate) + +-- | Intended to be used for unfolding in streaming libraries, `nextRow` +-- takes a total number of rows (which can be found with `ntuples`) +-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`, +-- otherwise returning the row along with the next row number. +nextRow + :: MonadIO io + => LibPQ.Row -- ^ total number of rows + -> Result y -- ^ result + -> LibPQ.Row -- ^ row number + -> io (Maybe (LibPQ.Row, y)) +nextRow total (Result decode result) r + = liftIO $ if r >= total then return Nothing else do + numCols <- LibPQ.nfields result + row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] + case SOP.fromList row' of + Nothing -> throw $ ColumnsException "nextRow" numCols + Just row -> case execDecodeRow decode row of + Left parseError -> throw $ DecodingException "nextRow" parseError + Right y -> return $ Just (r+1, y) + +okResult_ :: MonadIO io => LibPQ.Result -> io () +okResult_ result = liftIO $ do + status <- LibPQ.resultStatus result + case status of + LibPQ.CommandOk -> return () + LibPQ.TuplesOk -> return () + _ -> do + stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate + case stateCodeMaybe of + Nothing -> throw $ ConnectionException "LibPQ.resultErrorField" + Just stateCode -> do + msgMaybe <- LibPQ.resultErrorMessage result + case msgMaybe of + Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage" + Just msg -> throw . SQLException $ SQLState status stateCode msg + +-- | Lifts actions on results from @LibPQ@. +liftResult + :: MonadIO io + => (LibPQ.Result -> IO x) + -> Result y -> io x +liftResult f (Result _ result) = liftIO $ f result + +execDecodeRow + :: DecodeRow row y + -> SOP.NP (SOP.K (Maybe ByteString)) row + -> Either Text y +execDecodeRow decode = runDecodeRow decode diff --git a/src/Squeal/PostgreSQL/Session/Statement.hs b/src/Squeal/PostgreSQL/Session/Statement.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Statement.hs @@ -0,0 +1,220 @@ +{-| +Module: Squeal.PostgreSQL.Session.Statement +Description: statements +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +A top-level `Statement` type wraps a `Squeal.PostgreSQL.Query.Query` +or `Squeal.PostgreSQL.Manipulation.Manipulation` +together with an `EncodeParams` and a `DecodeRow`. +-} + +{-# LANGUAGE + DataKinds + , DeriveFunctor + , DeriveFoldable + , DeriveGeneric + , DeriveTraversable + , FlexibleContexts + , GADTs + , RankNTypes +#-} + +module Squeal.PostgreSQL.Session.Statement + ( -- * Statement + Statement (..) + , query + , manipulation + -- * Prepared + , Prepared (..) + ) where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Monad +import Control.Monad.Fix +import Data.Functor.Contravariant +import Data.Profunctor +import Data.Profunctor.Traversing +import GHC.Generics +import Prelude hiding ((.),id) + +import qualified Generics.SOP as SOP + +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Session.Decode +import Squeal.PostgreSQL.Session.Encode +import Squeal.PostgreSQL.Session.Oid +import Squeal.PostgreSQL.Query +import Squeal.PostgreSQL.Render hiding ((<+>)) + +-- | A `Statement` consists of a `Squeal.PostgreSQL.Statement.Manipulation` +-- or a `Squeal.PostgreSQL.Session.Statement.Query` that can be run +-- in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. +data Statement db x y where + -- | Constructor for a data manipulation language `Statement` + Manipulation + :: (SOP.All (OidOfNull db) params, SOP.SListI row) + => EncodeParams db params x -- ^ encoding of parameters + -> DecodeRow row y -- ^ decoding of returned rows + -> Manipulation '[] db params row + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, + -- `Squeal.PostgreSQL.Manipulation.Update.update`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... + -> Statement db x y + -- | Constructor for a structured query language `Statement` + Query + :: (SOP.All (OidOfNull db) params, SOP.SListI row) + => EncodeParams db params x -- ^ encoding of parameters + -> DecodeRow row y -- ^ decoding of returned rows + -> Query '[] '[] db params row + -- ^ `Squeal.PostgreSQL.Query.Select.select`, + -- `Squeal.PostgreSQL.Query.Values.values`, ... + -> Statement db x y + +instance Profunctor (Statement db) where + lmap f (Manipulation encode decode q) = + Manipulation (contramap f encode) decode q + lmap f (Query encode decode q) = + Query (contramap f encode) decode q + rmap f (Manipulation encode decode q) = + Manipulation encode (fmap f decode) q + rmap f (Query encode decode q) = + Query encode (fmap f decode) q + dimap f g (Manipulation encode decode q) = + Manipulation (contramap f encode) (fmap g decode) q + dimap f g (Query encode decode q) = + Query (contramap f encode) (fmap g decode) q + +instance Functor (Statement db x) where fmap = rmap + +instance RenderSQL (Statement db x y) where + renderSQL (Manipulation _ _ q) = renderSQL q + renderSQL (Query _ _ q) = renderSQL q + +-- | Smart constructor for a structured query language `Statement` +query :: + ( GenericParams db params x xs + , GenericRow row y ys + ) => Query '[] '[] db params row + -- ^ `Squeal.PostgreSQL.Query.Select.select`, + -- `Squeal.PostgreSQL.Query.Values.values`, ... + -> Statement db x y +query = Query genericParams genericRow + +-- | Smart constructor for a data manipulation language `Statement` +manipulation :: + ( GenericParams db params x xs + , GenericRow row y ys + ) => Manipulation '[] db params row + -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, + -- `Squeal.PostgreSQL.Manipulation.Update.update`, + -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... + -> Statement db x y +manipulation = Manipulation genericParams genericRow + +{- | +`Squeal.PostgreSQL.Session.Monad.prepare` and +`Squeal.PostgreSQL.Session.Monad.prepare_` create a `Prepared` statement. +A `Prepared` statement is a server-side object +that can be used to optimize performance. +When `Squeal.PostgreSQL.Session.Monad.prepare` +or `Squeal.PostgreSQL.Session.Monad.prepare_` is executed, +the specified `Statement` is parsed, analyzed, and rewritten. + +When the `runPrepared` command is subsequently issued, +the `Prepared` statement is planned and executed. +This division of labor avoids repetitive parse analysis work, +while allowing the execution plan to +depend on the specific parameter values supplied. + +`Prepared` statements only last for the duration +of the current database session. +`Prepared` statements can be manually cleaned up +using the `deallocate` command. +-} +data Prepared m x y = Prepared + { runPrepared :: x -> m y -- ^ execute a prepared statement + , deallocate :: m () -- ^ manually clean up a prepared statement + } deriving (Functor, Generic, Generic1) + +instance Applicative m => Applicative (Prepared m x) where + pure a = Prepared (\_ -> pure a) (pure ()) + p1 <*> p2 = Prepared + (run2 (<*>) p1 p2) + (deallocate p1 *> deallocate p2) + +instance Alternative m => Alternative (Prepared m x) where + empty = Prepared (runKleisli empty) empty + p1 <|> p2 = Prepared + (run2 (<|>) p1 p2) + (deallocate p1 *> deallocate p2) + +instance Functor m => Profunctor (Prepared m) where + dimap g f prepared = Prepared + (fmap f . runPrepared prepared . g) + (deallocate prepared) + +instance Monad m => Strong (Prepared m) where + first' p = Prepared (run1 first' p) (deallocate p) + second' p = Prepared (run1 second' p) (deallocate p) + +instance Monad m => Choice (Prepared m) where + left' p = Prepared (run1 left' p) (deallocate p) + right' p = Prepared (run1 right' p) (deallocate p) + +instance MonadFix m => Costrong (Prepared m) where + unfirst p = Prepared (run1 unfirst p) (deallocate p) + unsecond p = Prepared (run1 unsecond p) (deallocate p) + +instance Monad m => Category (Prepared m) where + id = Prepared return (return ()) + cd . ab = Prepared + (runPrepared ab >=> runPrepared cd) + (deallocate ab >> deallocate cd) + +instance Monad m => Arrow (Prepared m) where + arr ab = Prepared (return . ab) (return ()) + first = first' + second = second' + ab *** cd = first ab >>> second cd + ab &&& ac = Prepared + (run2 (&&&) ab ac) + (deallocate ab >> deallocate ac) + +instance Monad m => ArrowChoice (Prepared m) where + left = left' + right = right' + ab +++ cd = left ab >>> right cd + bd ||| cd = Prepared + (run2 (|||) bd cd) + (deallocate bd >> deallocate cd) + +instance MonadFix m => ArrowLoop (Prepared m) where + loop p = Prepared (run1 loop p) (deallocate p) + +instance MonadPlus m => ArrowZero (Prepared m) where + zeroArrow = Prepared (runKleisli zeroArrow) (return ()) + +instance MonadPlus m => ArrowPlus (Prepared m) where + p1 <+> p2 = Prepared + (run2 (<+>) p1 p2) + (deallocate p1 >> deallocate p2) + +instance Monad m => Traversing (Prepared m) where + traverse' p = Prepared (run1 traverse' p) (deallocate p) + +-- helper functions + +run1 + :: (Kleisli m a b -> Kleisli m c d) + -> Prepared m a b -> c -> m d +run1 m = runKleisli . m . Kleisli . runPrepared + +run2 + :: (Kleisli m a b -> Kleisli m c d -> Kleisli m e f) + -> Prepared m a b -> Prepared m c d -> e -> m f +run2 (?) p1 p2 = runKleisli $ + Kleisli (runPrepared p1) ? Kleisli (runPrepared p2) diff --git a/src/Squeal/PostgreSQL/Session/Transaction.hs b/src/Squeal/PostgreSQL/Session/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Transaction.hs @@ -0,0 +1,156 @@ +{-| +Module: Squeal.PostgreSQL.Session.Transaction +Description: transaction control language +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +transaction control language +-} + +{-# LANGUAGE + MonoLocalBinds + , RankNTypes +#-} + +module Squeal.PostgreSQL.Session.Transaction + ( -- * Transaction + Transaction + , transactionally + , transactionally_ + , transactionallyRetry + , transactionallyRetry_ + , ephemerally + , ephemerally_ + , withSavepoint + -- * Transaction Mode + , TransactionMode (..) + , defaultMode + , longRunningMode + , retryMode + , IsolationLevel (..) + , AccessMode (..) + , DeferrableMode (..) + ) where + +import Control.Monad.Catch +import Data.ByteString + +import Squeal.PostgreSQL.Session.Monad +import Squeal.PostgreSQL.Session.Result +import Squeal.PostgreSQL.Session.Transaction.Unsafe + ( TransactionMode (..) + , defaultMode + , longRunningMode + , retryMode + , IsolationLevel (..) + , AccessMode (..) + , DeferrableMode (..) + ) +import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe + +{- | A type of "safe" `Transaction`s, +do-blocks that permit only +database operations, pure functions, and synchronous exception handling +forbidding arbitrary `IO` operations. + +To permit arbitrary `IO`, + +>>> import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe + +Then use the @Unsafe@ qualified form of the functions below. + +A safe `Transaction` can be run in two ways, + +1) it can be run directly in `IO` because as a + universally quantified type, + @Transaction db x@ permits interpretation in "subtypes" like + @(MonadPQ db m, MonadIO m, MonadCatch m) => m x@ + or + @PQ db db IO x@ + +2) it can be run in a transaction block, using + `transactionally`, `ephemerally`, + or `transactionallyRetry` +-} +type Transaction db x = forall m. + ( MonadPQ db m + , MonadResult m + , MonadCatch m + ) => m x + +{- | Run a computation `transactionally`; +first `Unsafe.begin`, +then run the computation, +`onException` `Unsafe.rollback` and rethrow the exception, +otherwise `Unsafe.commit` and `return` the result. +-} +transactionally + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => TransactionMode + -> Transaction db x -- ^ run inside a transaction + -> tx x +transactionally mode tx = Unsafe.transactionally mode tx + +-- | Run a computation `transactionally_`, in `defaultMode`. +transactionally_ + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => Transaction db x -- ^ run inside a transaction + -> tx x +transactionally_ tx = Unsafe.transactionally_ tx + +{- | +`transactionallyRetry` a computation; + +* first `Unsafe.begin`, +* then `try` the computation, + - if it raises a serialization failure or deadloack detection, + then `Unsafe.rollback` and restart the transaction, + - if it raises any other exception then `Unsafe.rollback` and rethrow the exception, + - otherwise `Unsafe.commit` and `return` the result. +-} +transactionallyRetry + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => TransactionMode + -> Transaction db x -- ^ run inside a transaction + -> tx x +transactionallyRetry mode tx = Unsafe.transactionallyRetry mode tx + +{- | `transactionallyRetry` in `retryMode`. -} +transactionallyRetry_ + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => Transaction db x -- ^ run inside a transaction + -> tx x +transactionallyRetry_ tx = Unsafe.transactionallyRetry_ tx + +{- | Run a computation `ephemerally`; +Like `transactionally` but always `Unsafe.rollback`, useful in testing. +-} +ephemerally + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => TransactionMode + -> Transaction db x -- ^ run inside an ephemeral transaction + -> tx x +ephemerally mode tx = Unsafe.ephemerally mode tx + +{- | Run a computation `ephemerally` in `defaultMode`. -} +ephemerally_ + :: (MonadMask tx, MonadResult tx, MonadPQ db tx) + => Transaction db x -- ^ run inside an ephemeral transaction + -> tx x +ephemerally_ tx = Unsafe.ephemerally_ tx + +{- | `withSavepoint`, used in a transaction block, +allows a form of nested transactions, +creating a savepoint, then running a transaction, +rolling back to the savepoint if it returned `Left`, +then releasing the savepoint and returning transaction's result. + +Make sure to run `withSavepoint` in a transaction block, +not directly or you will provoke a SQL exception. +-} +withSavepoint + :: ByteString -- ^ savepoint name + -> Transaction db (Either e x) + -> Transaction db (Either e x) +withSavepoint sv tx = Unsafe.withSavepoint sv tx diff --git a/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs b/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs @@ -0,0 +1,300 @@ +{-| +Module: Squeal.PostgreSQL.Session.Transaction.Unsafe +Description: unsafe transaction control language +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +transaction control language permitting arbitrary `IO` +-} + +{-# LANGUAGE + DataKinds + , FlexibleContexts + , LambdaCase + , OverloadedStrings + , DataKinds + , PolyKinds +#-} + +module Squeal.PostgreSQL.Session.Transaction.Unsafe + ( -- * Transaction + transactionally + , transactionally_ + , transactionallyRetry + , transactionallyRetry_ + , ephemerally + , ephemerally_ + , begin + , commit + , rollback + , withSavepoint + -- * Transaction Mode + , TransactionMode (..) + , defaultMode + , retryMode + , longRunningMode + , IsolationLevel (..) + , AccessMode (..) + , DeferrableMode (..) + ) where + +import Control.Monad +import Control.Monad.Catch +import Data.ByteString +import Data.Either + +import Squeal.PostgreSQL.Manipulation +import Squeal.PostgreSQL.Render +import Squeal.PostgreSQL.Session.Exception +import Squeal.PostgreSQL.Session.Monad + +{- | Run a computation `transactionally`; +first `begin`, +then run the computation, +`onException` `rollback` and rethrow the exception, +otherwise `commit` and `return` the result. +-} +transactionally + :: (MonadMask tx, MonadPQ db tx) + => TransactionMode + -> tx x -- ^ run inside a transaction + -> tx x +transactionally mode tx = mask $ \restore -> do + manipulate_ $ begin mode + result <- restore tx `onException` manipulate_ rollback + manipulate_ commit + return result + +-- | Run a computation `transactionally_`, in `defaultMode`. +transactionally_ + :: (MonadMask tx, MonadPQ db tx) + => tx x -- ^ run inside a transaction + -> tx x +transactionally_ = transactionally defaultMode + +{- | +`transactionallyRetry` a computation; + +* first `begin`, +* then `try` the computation, + - if it raises a serialization failure or deadlock detection, + then `rollback` and restart the transaction, + - if it raises any other exception then `rollback` and rethrow the exception, + - otherwise `commit` and `return` the result. +-} +transactionallyRetry + :: (MonadMask tx, MonadPQ db tx) + => TransactionMode + -> tx x -- ^ run inside a transaction + -> tx x +transactionallyRetry mode tx = mask $ \restore -> + loop . try $ do + x <- restore tx + manipulate_ commit + return x + where + loop attempt = do + manipulate_ $ begin mode + attempt >>= \case + Left (SerializationFailure _) -> do + manipulate_ rollback + loop attempt + Left (DeadlockDetected _) -> do + manipulate_ rollback + loop attempt + Left err -> do + manipulate_ rollback + throwM err + Right x -> return x + +{- | `transactionallyRetry` in `retryMode`. -} +transactionallyRetry_ + :: (MonadMask tx, MonadPQ db tx) + => tx x -- ^ run inside a transaction + -> tx x +transactionallyRetry_ = transactionallyRetry retryMode + +{- | Run a computation `ephemerally`; +Like `transactionally` but always `rollback`, useful in testing. +-} +ephemerally + :: (MonadMask tx, MonadPQ db tx) + => TransactionMode + -> tx x -- ^ run inside an ephemeral transaction + -> tx x +ephemerally mode tx = mask $ \restore -> do + manipulate_ $ begin mode + result <- restore tx `onException` (manipulate_ rollback) + manipulate_ rollback + return result + +{- | Run a computation `ephemerally` in `defaultMode`. -} +ephemerally_ + :: (MonadMask tx, MonadPQ db tx) + => tx x -- ^ run inside an ephemeral transaction + -> tx x +ephemerally_ = ephemerally defaultMode + +-- | @BEGIN@ a transaction. +begin :: TransactionMode -> Manipulation_ db () () +begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode + +-- | @COMMIT@ a transaction. +commit :: Manipulation_ db () () +commit = UnsafeManipulation "COMMIT" + +-- | @ROLLBACK@ a transaction. +rollback :: Manipulation_ db () () +rollback = UnsafeManipulation "ROLLBACK" + +{- | `withSavepoint`, used in a transaction block, +allows a form of nested transactions, +creating a savepoint, then running a transaction, +rolling back to the savepoint if it returned `Left`, +then releasing the savepoint and returning transaction's result. + +Make sure to run `withSavepoint` in a transaction block, +not directly or you will provoke a SQL exception. +-} +withSavepoint + :: MonadPQ db tx + => ByteString -- ^ savepoint name + -> tx (Either e x) + -> tx (Either e x) +withSavepoint savepoint tx = do + let svpt = "SAVEPOINT" <+> savepoint + manipulate_ $ UnsafeManipulation $ svpt + e_x <- tx + when (isLeft e_x) $ + manipulate_ $ UnsafeManipulation $ "ROLLBACK TO" <+> svpt + manipulate_ $ UnsafeManipulation $ "RELEASE" <+> svpt + return e_x + +-- | The available transaction characteristics are the transaction `IsolationLevel`, +-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`. +data TransactionMode = TransactionMode + { isolationLevel :: IsolationLevel + , accessMode :: AccessMode + , deferrableMode :: DeferrableMode + } deriving (Show, Eq) + +-- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`, +-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`. +defaultMode :: TransactionMode +defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable + +-- | `TransactionMode` with a `Serializable` `IsolationLevel`, +-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`, +-- appropriate for short-lived queries or manipulations. +retryMode :: TransactionMode +retryMode = TransactionMode Serializable ReadWrite NotDeferrable + +-- | `TransactionMode` with a `Serializable` `IsolationLevel`, +-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`. +-- This mode is well suited for long-running reports or backups. +longRunningMode :: TransactionMode +longRunningMode = TransactionMode Serializable ReadOnly Deferrable + +-- | Render a `TransactionMode`. +instance RenderSQL TransactionMode where + renderSQL mode = + "ISOLATION LEVEL" + <+> renderSQL (isolationLevel mode) + <+> renderSQL (accessMode mode) + <+> renderSQL (deferrableMode mode) + +-- | The SQL standard defines four levels of transaction isolation. +-- The most strict is `Serializable`, which is defined by the standard in a paragraph +-- which says that any concurrent execution of a set of `Serializable` transactions is +-- guaranteed to produce the same effect as running them one at a time in some order. +-- The other three levels are defined in terms of phenomena, resulting from interaction +-- between concurrent transactions, which must not occur at each level. +-- The phenomena which are prohibited at various levels are: +-- +-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction. +-- +-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data +-- has been modified by another transaction (that committed since the initial read). +-- +-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy +-- a search condition and finds that the set of rows satisfying the condition +-- has changed due to another recently-committed transaction. +-- +-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent +-- with all possible orderings of running those transactions one at a time. +-- +-- In PostgreSQL, you can request any of the four standard transaction +-- isolation levels, but internally only three distinct isolation levels are implemented, +-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`. +-- This is because it is the only sensible way to map the standard isolation levels to +-- PostgreSQL's multiversion concurrency control architecture. +data IsolationLevel + = Serializable + -- ^ Dirty read is not possible. + -- Nonrepeatable read is not possible. + -- Phantom read is not possible. + -- Serialization anomaly is not possible. + | RepeatableRead + -- ^ Dirty read is not possible. + -- Nonrepeatable read is not possible. + -- Phantom read is not possible. + -- Serialization anomaly is possible. + | ReadCommitted + -- ^ Dirty read is not possible. + -- Nonrepeatable read is possible. + -- Phantom read is possible. + -- Serialization anomaly is possible. + | ReadUncommitted + -- ^ Dirty read is not possible. + -- Nonrepeatable read is possible. + -- Phantom read is possible. + -- Serialization anomaly is possible. + deriving (Show, Eq) + +-- | Render an `IsolationLevel`. +instance RenderSQL IsolationLevel where + renderSQL = \case + Serializable -> "SERIALIZABLE" + ReadCommitted -> "READ COMMITTED" + ReadUncommitted -> "READ UNCOMMITTED" + RepeatableRead -> "REPEATABLE READ" + +-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`. +-- `ReadWrite` is the default. When a transaction is `ReadOnly`, +-- the following SQL commands are disallowed: +-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@ +-- if the table they would write to is not a temporary table; +-- all @CREATE@, @ALTER@, and @DROP@ commands; +-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@; +-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed. +-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk. +data AccessMode + = ReadWrite + | ReadOnly + deriving (Show, Eq) + +-- | Render an `AccessMode`. +instance RenderSQL AccessMode where + renderSQL = \case + ReadWrite -> "READ WRITE" + ReadOnly -> "READ ONLY" + +-- | The `Deferrable` transaction property has no effect +-- unless the transaction is also `Serializable` and `ReadOnly`. +-- When all three of these properties are selected for a transaction, +-- the transaction may block when first acquiring its snapshot, +-- after which it is able to run without the normal overhead of a +-- `Serializable` transaction and without any risk of contributing +-- to or being canceled by a serialization failure. +-- This `longRunningMode` is well suited for long-running reports or backups. +data DeferrableMode + = Deferrable + | NotDeferrable + deriving (Show, Eq) + +-- | Render a `DeferrableMode`. +instance RenderSQL DeferrableMode where + renderSQL = \case + Deferrable -> "DEFERRABLE" + NotDeferrable -> "NOT DEFERRABLE" diff --git a/src/Squeal/PostgreSQL/Transaction.hs b/src/Squeal/PostgreSQL/Transaction.hs deleted file mode 100644 --- a/src/Squeal/PostgreSQL/Transaction.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Transaction -Description: Squeal transaction control language -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Squeal transaction control language. --} - -{-# LANGUAGE - DataKinds - , FlexibleContexts - , LambdaCase - , OverloadedStrings - , TypeInType -#-} - -module Squeal.PostgreSQL.Transaction - ( -- * Transaction - transactionally - , transactionally_ - , transactionallyRetry - , ephemerally - , ephemerally_ - , begin - , commit - , rollback - -- * Transaction Mode - , TransactionMode (..) - , defaultMode - , longRunningMode - , IsolationLevel (..) - , AccessMode (..) - , DeferrableMode (..) - ) where - -import UnliftIO - -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.PQ - -{- | Run a computation `transactionally`; -first `begin`, -then run the computation, -`onException` `rollback` and rethrow the exception, -otherwise `commit` and `return` the result. --} -transactionally - :: (MonadUnliftIO tx, MonadPQ schemas tx) - => TransactionMode - -> tx x -- ^ run inside a transaction - -> tx x -transactionally mode tx = mask $ \restore -> do - manipulate_ $ begin mode - result <- restore tx `onException` (manipulate_ rollback) - manipulate_ commit - return result - --- | Run a computation `transactionally_`, in `defaultMode`. -transactionally_ - :: (MonadUnliftIO tx, MonadPQ schemas tx) - => tx x -- ^ run inside a transaction - -> tx x -transactionally_ = transactionally defaultMode - -{- | -`transactionallyRetry` a computation; - -* first `begin`, -* then `try` the computation, - - if it raises a serialization failure then `rollback` and restart the transaction, - - if it raises any other exception then `rollback` and rethrow the exception, - - otherwise `commit` and `return` the result. --} -transactionallyRetry - :: (MonadUnliftIO tx, MonadPQ schemas tx) - => TransactionMode - -> tx x -- ^ run inside a transaction - -> tx x -transactionallyRetry mode tx = mask $ \restore -> - loop . try $ do - x <- restore tx - manipulate_ commit - return x - where - loop attempt = do - manipulate_ $ begin mode - attempt >>= \case - Left (PQException (PQState _ (Just "40001") _)) -> do - manipulate_ rollback - loop attempt - Left err -> do - manipulate_ rollback - throwIO err - Right x -> return x - -{- | Run a computation `ephemerally`; -Like `transactionally` but always `rollback`, useful in testing. --} -ephemerally - :: (MonadUnliftIO tx, MonadPQ schemas tx) - => TransactionMode - -> tx x -- ^ run inside an ephemeral transaction - -> tx x -ephemerally mode tx = mask $ \restore -> do - manipulate_ $ begin mode - result <- restore tx `onException` (manipulate_ rollback) - manipulate_ rollback - return result - -{- | Run a computation `ephemerally` in `defaultMode`. -} -ephemerally_ - :: (MonadUnliftIO tx, MonadPQ schemas tx) - => tx x -- ^ run inside an ephemeral transaction - -> tx x -ephemerally_ = ephemerally defaultMode - --- | @BEGIN@ a transaction. -begin :: TransactionMode -> Manipulation_ schemas () () -begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode - --- | @COMMIT@ a transaction. -commit :: Manipulation_ schemas () () -commit = UnsafeManipulation "COMMIT" - --- | @ROLLBACK@ a transaction. -rollback :: Manipulation_ schemas () () -rollback = UnsafeManipulation "ROLLBACK" - --- | The available transaction characteristics are the transaction `IsolationLevel`, --- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`. -data TransactionMode = TransactionMode - { isolationLevel :: IsolationLevel - , accessMode :: AccessMode - , deferrableMode :: DeferrableMode - } deriving (Show, Eq) - --- | `TransactionMode` with a `Serializable` `IsolationLevel`, --- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`. -defaultMode :: TransactionMode -defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable - --- | `TransactionMode` with a `Serializable` `IsolationLevel`, --- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`. --- This mode is well suited for long-running reports or backups. -longRunningMode :: TransactionMode -longRunningMode = TransactionMode Serializable ReadOnly Deferrable - --- | Render a `TransactionMode`. -instance RenderSQL TransactionMode where - renderSQL mode = - "ISOLATION LEVEL" - <+> renderSQL (isolationLevel mode) - <+> renderSQL (accessMode mode) - <+> renderSQL (deferrableMode mode) - --- | The SQL standard defines four levels of transaction isolation. --- The most strict is `Serializable`, which is defined by the standard in a paragraph --- which says that any concurrent execution of a set of `Serializable` transactions is --- guaranteed to produce the same effect as running them one at a time in some order. --- The other three levels are defined in terms of phenomena, resulting from interaction --- between concurrent transactions, which must not occur at each level. --- The phenomena which are prohibited at various levels are: --- --- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction. --- --- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data --- has been modified by another transaction (that committed since the initial read). --- --- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy --- a search condition and finds that the set of rows satisfying the condition --- has changed due to another recently-committed transaction. --- --- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent --- with all possible orderings of running those transactions one at a time. --- --- In PostgreSQL, you can request any of the four standard transaction --- isolation levels, but internally only three distinct isolation levels are implemented, --- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`. --- This is because it is the only sensible way to map the standard isolation levels to --- PostgreSQL's multiversion concurrency control architecture. -data IsolationLevel - = Serializable - -- ^ Dirty read is not possible. - -- Nonrepeatable read is not possible. - -- Phantom read is not possible. - -- Serialization anomaly is not possible. - | RepeatableRead - -- ^ Dirty read is not possible. - -- Nonrepeatable read is not possible. - -- Phantom read is not possible. - -- Serialization anomaly is possible. - | ReadCommitted - -- ^ Dirty read is not possible. - -- Nonrepeatable read is possible. - -- Phantom read is possible. - -- Serialization anomaly is possible. - | ReadUncommitted - -- ^ Dirty read is not possible. - -- Nonrepeatable read is possible. - -- Phantom read is possible. - -- Serialization anomaly is possible. - deriving (Show, Eq) - --- | Render an `IsolationLevel`. -instance RenderSQL IsolationLevel where - renderSQL = \case - Serializable -> "SERIALIZABLE" - ReadCommitted -> "READ COMMITTED" - ReadUncommitted -> "READ UNCOMMITTED" - RepeatableRead -> "REPEATABLE READ" - --- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`. --- `ReadWrite` is the default. When a transaction is `ReadOnly`, --- the following SQL commands are disallowed: --- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@ --- if the table they would write to is not a temporary table; --- all @CREATE@, @ALTER@, and @DROP@ commands; --- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@; --- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed. --- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk. -data AccessMode - = ReadWrite - | ReadOnly - deriving (Show, Eq) - --- | Render an `AccessMode`. -instance RenderSQL AccessMode where - renderSQL = \case - ReadWrite -> "READ WRITE" - ReadOnly -> "READ ONLY" - --- | The `Deferrable` transaction property has no effect --- unless the transaction is also `Serializable` and `ReadOnly`. --- When all three of these properties are selected for a transaction, --- the transaction may block when first acquiring its snapshot, --- after which it is able to run without the normal overhead of a --- `Serializable` transaction and without any risk of contributing --- to or being canceled by a serialization failure. --- This `longRunningMode` is well suited for long-running reports or backups. -data DeferrableMode - = Deferrable - | NotDeferrable - deriving (Show, Eq) - --- | Render a `DeferrableMode`. -instance RenderSQL DeferrableMode where - renderSQL = \case - Deferrable -> "DEFERRABLE" - NotDeferrable -> "NOT DEFERRABLE" diff --git a/src/Squeal/PostgreSQL/Type.hs b/src/Squeal/PostgreSQL/Type.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Type.hs @@ -0,0 +1,202 @@ +{-| +Module: Squeal.PostgreSQL.Type +Description: types +Copyright: (c) Eitan Chatav, 2010 +Maintainer: eitan@morphism.tech +Stability: experimental + +storage newtypes +-} +{-# LANGUAGE + AllowAmbiguousTypes + , DeriveAnyClass + , DeriveFoldable + , DeriveFunctor + , DeriveGeneric + , DeriveTraversable + , DerivingStrategies + , DefaultSignatures + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Type + ( -- * Storage newtypes + Money (..) + , Json (..) + , Jsonb (..) + , Composite (..) + , Enumerated (..) + , VarArray (..) + , FixArray (..) + , VarChar, varChar, getVarChar + , FixChar, fixChar, getFixChar + , Only (..) + ) where + +import Data.Proxy +import Data.Int (Int64) +import GHC.TypeLits + +import qualified Data.Text as Strict (Text) +import qualified Data.Text as Strict.Text +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP + +-- $setup +-- >>> import Squeal.PostgreSQL + +{- | 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) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +{- | 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) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +{- | 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) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +{- | 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) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +{- | 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) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +{- | The `VarArray` newtype is an indication that the Haskell +type it's applied to should be stored as a +`Squeal.PostgreSQL.Type.Schema.PGvararray`. + +>>> import Data.Vector +>>> :kind! PG (VarArray (Vector Double)) +PG (VarArray (Vector Double)) :: PGType += 'PGvararray ('NotNull 'PGfloat8) +-} +newtype VarArray arr + = VarArray {getVarArray :: arr} + deriving stock (Eq, Ord, Show, Read, GHC.Generic) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +{- | The `FixArray` newtype is an indication that the Haskell +type it's applied to should be stored as a +`Squeal.PostgreSQL.Type.Schema.PGfixarray`. + +>>> :kind! PG (FixArray ((Double, Double), (Double, Double))) +PG (FixArray ((Double, Double), (Double, Double))) :: PGType += 'PGfixarray '[2, 2] ('NotNull 'PGfloat8) +-} +newtype FixArray arr = FixArray {getFixArray :: arr} + deriving stock (Eq, Ord, Show, Read, GHC.Generic) + deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) + +-- | `Only` is a 1-tuple type, useful for encoding or decoding a singleton +newtype Only x = Only { fromOnly :: x } + deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic) +instance SOP.Generic (Only x) +instance SOP.HasDatatypeInfo (Only x) + +{- | 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) + +-- | Constructor for `VarChar` +varChar :: forall n . KnownNat n => Strict.Text -> Maybe (VarChar n) +varChar t = + if Strict.Text.length t <= fromIntegral (natVal @n Proxy) + then Just $ VarChar t + else Nothing + +-- | Access the `Strict.Text` of a `VarChar` +getVarChar :: VarChar n -> Strict.Text +getVarChar (VarChar t) = t + +{- | 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) + +-- | Constructor for `FixChar` +fixChar :: forall n . KnownNat n => Strict.Text -> Maybe (FixChar n) +fixChar t = + if Strict.Text.length t == fromIntegral (natVal @n Proxy) + then Just $ FixChar t + else Nothing + +-- | Access the `Strict.Text` of a `FixChar` +getFixChar :: FixChar n -> Strict.Text +getFixChar (FixChar t) = t diff --git a/src/Squeal/PostgreSQL/Type/Alias.hs b/src/Squeal/PostgreSQL/Type/Alias.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Type/Alias.hs @@ -0,0 +1,349 @@ +{-| +Module: Squeal.PostgreSQL.Type.Alias +Description: aliases +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +This module embeds Postgres's alias system in Haskell in +a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension, +Squeal can reference aliases by prepending with a @#@. +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , OverloadedStrings + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilyDependencies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Type.Alias + ( -- * Aliases + (:::) + , Alias (..) + , IsLabel (..) + , Aliased (As) + , Aliasable (as) + , renderAliased + , mapAliased + , Has + , HasUnique + , HasErr + , HasAll + , HasIn + -- * Qualified Aliases + , QualifiedAlias (..) + , IsQualified (..) + -- * Grouping + , Grouping (..) + , GroupedBy + -- * Error reporting + , LookupFailedError + , PrettyPrintHaystack + , PrettyPrintInfo(..) + , MismatchError + , LookupFailedError' + , DefaultPrettyPrinter + , MismatchError' + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) +import Data.String (fromString) +import GHC.Exts (Any, Constraint) +import GHC.OverloadedLabels +import GHC.TypeLits + +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | The alias operator `:::` is like a promoted version of `As`, +-- a type level pair between an alias and some type. +type (:::) (alias :: Symbol) ty = '(alias,ty) +infixr 6 ::: + + +-- | `Grouping` is an auxiliary namespace, created by +-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.groupBy`), and used +-- for typesafe aggregation +data Grouping + = Ungrouped -- ^ no aggregation permitted + | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped + +{- | A `GroupedBy` constraint indicates that a table qualified column is +a member of the auxiliary namespace created by @GROUP BY@ clauses and thus, +may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating. +-} +class (KnownSymbol table, KnownSymbol column) + => GroupedBy table column bys where +instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column) + => GroupedBy table column ('(table,column) ': bys) +instance {-# OVERLAPPABLE #-} + ( KnownSymbol table + , KnownSymbol column + , GroupedBy table column bys + ) => GroupedBy table column (tabcol ': bys) + +-- | `Alias`es are proxies for a type level string or `Symbol` +-- and have an `IsLabel` instance so that with @-XOverloadedLabels@ +-- +-- >>> :set -XOverloadedLabels +-- >>> #foobar :: Alias "foobar" +-- Alias +data Alias (alias :: Symbol) = Alias + deriving (Eq,GHC.Generic,Ord,Show,NFData) +instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where + fromLabel = Alias +instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where + fromLabel = fromLabel SOP.:* Nil +-- | >>> printSQL (#jimbob :: Alias "jimbob") +-- "jimbob" +instance KnownSymbol alias => RenderSQL (Alias alias) where + renderSQL = doubleQuoted . fromString . symbolVal + +-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"]) +-- "jimbob", "kandi" +instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where + renderSQL + = commaSeparated + . SOP.hcollapse + . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL) + +-- | The `As` operator is used to name an expression. `As` is like a demoted +-- version of `:::`. +-- +-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String) +-- As (Just "hello") Alias +data Aliased expression aliased where + As + :: KnownSymbol alias + => expression ty + -> Alias alias + -> Aliased expression (alias ::: ty) +deriving instance Show (expression ty) + => Show (Aliased expression (alias ::: ty)) +deriving instance Eq (expression ty) + => Eq (Aliased expression (alias ::: ty)) +deriving instance Ord (expression ty) + => Ord (Aliased expression (alias ::: ty)) +instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2) + => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where + fromLabel = fromLabel @alias2 `As` fromLabel @alias1 + +-- | The `Aliasable` class provides a way to scrap your `Nil`s +-- in an `NP` list of `Aliased` expressions. +class KnownSymbol alias => Aliasable alias expression aliased + | aliased -> expression + , aliased -> alias + where as :: expression -> Alias alias -> aliased +instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias + (expression ty) + (Aliased expression aliased) + where + as = As +instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias + (expression ty) + (NP (Aliased expression) tys) + where + expression `as` alias = expression `As` alias SOP.:* Nil + +-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just") +-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int) +-- "Just AS \"an_int\"" +renderAliased + :: (forall ty. expression ty -> ByteString) + -> Aliased expression aliased + -> ByteString +renderAliased render (expression `As` alias) = + render expression <> " AS " <> renderSQL alias + +-- | Map a function over an `Aliased` expression. +mapAliased + :: (expr x -> expr y) + -> Aliased expr (alias ::: x) + -> Aliased expr (alias ::: y) +mapAliased f (x `As` alias) = f x `As` alias + +-- | @HasUnique alias fields field@ is a constraint that proves that +-- @fields@ is a singleton of @alias ::: field@. +type HasUnique alias fields field = fields ~ '[alias ::: field] + +-- | @Has alias fields field@ is a constraint that proves that +-- @fields@ has a field of @alias ::: field@, inferring @field@ +-- from @alias@ and @fields@. +class (KnownSymbol alias) => Has (alias :: Symbol) (fields :: [(Symbol, kind)]) (field :: kind) | alias fields -> field +-- having these instances forces 'Has' to inspect 'alias' and 'fields' and thereby fail before delegating to +-- 'HasErr', which means 'Has' shows up in error messages instead of 'HasErr' +instance {-# OVERLAPPING #-} (KnownSymbol alias, HasErr (alias ::: field0 ': fields) alias (alias ::: field0 ': fields) field1) + => Has alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr (field' ': fields) alias (field' ': fields) field) + => Has alias (field' ': fields) field +instance (KnownSymbol alias, HasErr '[] alias '[] field) + => Has alias '[] field + +{- | 'HasErr' is like `Has` except it also retains the original +list of fields being searched, so that error messages are more +useful. +-} +class KnownSymbol alias => + HasErr (allFields :: [(Symbol, kind)]) (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) + | alias fields -> field where +instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1, MismatchError alias allFields field0 field1) + => HasErr allFields alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr allFields alias fields field) + => HasErr allFields alias (field' ': fields) field +instance ( KnownSymbol alias + , LookupFailedError alias allFields -- report a nicer error + , field ~ Any -- required to satisfy the fundep + ) => HasErr allFields alias '[] field + +-- | @MismatchError@ reports a nicer error with more context when we successfully do a lookup but +-- find a different field than we expected. As a type family, it ensures that we only do the (expensive) +-- calculation of coming up with our pretty printing information when we actually have a mismatch +type family MismatchError (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where + MismatchError _ _ found found = () + MismatchError alias fields found expected = MismatchError' (MismatchError' () (DefaultPrettyPrinter fields) alias fields found expected) (PrettyPrintHaystack fields) alias fields found expected + +-- | @MismatchError'@ is the workhorse behind @MismatchError@, but taking an additional type as the first argument. We can put another type error +-- in there which will only show if @MismatchError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance +-- is missing +type family MismatchError' (err :: Constraint) (ppInfo :: PrettyPrintInfo) (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where + MismatchError' _ ('PrettyPrintInfo needleName haystackName _) alias fields found expected = TypeError + ( 'Text "Type mismatch when looking up " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType alias + ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" + -- we don't use a pretty haystack because we want to show the values + ':$$: 'ShowType fields + ':$$: 'Text "" + ':$$: 'Text "Expected: " ':<>: 'ShowType expected + ':$$: 'Text "But found: " ':<>: 'ShowType found + ':$$: 'Text "" + ) + +-- | @LookupFailedError@ reports a nicer error when we fail to look up some @needle@ in some @haystack@ +type LookupFailedError needle haystack = LookupFailedError' (LookupFailedError' () (DefaultPrettyPrinter haystack) needle haystack) (PrettyPrintHaystack haystack) needle haystack + +-- | @LookupFailedError'@ is the workhorse behind @LookupFailedError@, but taking an additional type as the first argument. We can put another type error +-- in there which will only show if @LookupFailedError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance +-- is missing +type family LookupFailedError' (fallbackForUnknownKind :: Constraint) (prettyPrintInfo :: PrettyPrintInfo) (needle :: Symbol) (haystack :: [(Symbol, k)]) :: Constraint where + LookupFailedError' _ ('PrettyPrintInfo needleName haystackName prettyHaystack) needle rawHaystack = TypeError + ( 'Text "Could not find " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType needle + ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" + ':$$: prettyHaystack + ':$$: 'Text "" + ':$$: 'Text "*Raw " ':<>: haystackName ':<>: 'Text "*:" + ':$$: 'ShowType rawHaystack + ':$$: 'Text "" + ) + +-- | @PrettyPrintInfo@ is a data type intended to be used at the type level +-- which describes how to pretty print a haystack in our custom errors. The general intention is we use @PrettyPrintHaystack@ +-- to define a more specific way of pretty printing our error information for each kind that we care about +data PrettyPrintInfo = PrettyPrintInfo + { _needleName :: ErrorMessage + , _haystackName :: ErrorMessage + , _haystackPrettyPrint :: ErrorMessage + } + +-- | 'PrettyPrintHaystack' allows us to use the kind of our haystack to come up +-- with nicer errors. It is implemented as an open type family for dependency reasons +type family PrettyPrintHaystack (haystack :: [(Symbol, k)]) :: PrettyPrintInfo + +-- | @DefaultPrettyPrinter@ provides a default we can use for kinds that don't provide an instance of @PrettyPrintInfo@, +-- although that should generally only be accidental +type family DefaultPrettyPrinter (haystack :: [(Symbol, k)]) :: PrettyPrintInfo where + DefaultPrettyPrinter (haystack :: [(Symbol, k)]) = 'PrettyPrintInfo + ('Text "some kind without a PrettyPrintHaystack instance (" ':<>: 'ShowType k ':<>: 'Text ")") + ('Text "associative list of that kind ([(Symbol, " ':<>: 'ShowType k ':<>: 'Text ")])") + ('ShowType (Sort (MapFst haystack))) + +{-| @HasIn fields (alias ::: field)@ is a constraint that proves that +@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to +choose which subfields to update. +-} +class HasIn fields field where +instance (Has alias fields field) => HasIn fields (alias ::: field) where + +-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer +-- a list of @subfields@. +class + ( SOP.All KnownSymbol aliases + ) => HasAll + (aliases :: [Symbol]) + (fields :: [(Symbol,kind)]) + (subfields :: [(Symbol,kind)]) + | aliases fields -> subfields where +instance {-# OVERLAPPING #-} HasAll '[] fields '[] +instance {-# OVERLAPPABLE #-} + (Has alias fields field, HasAll aliases fields subfields) + => HasAll (alias ': aliases) fields (alias ::: field ': subfields) + +-- | Analagous to `IsLabel`, the constraint +-- `IsQualified` defines `!` for a column alias qualified +-- by a table alias. +class IsQualified qualifier alias expression where + (!) :: Alias qualifier -> Alias alias -> expression + infixl 9 ! +instance IsQualified qualifier alias (Alias qualifier, Alias alias) where + (!) = (,) + +{-| `QualifiedAlias`es enables multi-schema support by allowing a reference +to a `Squeal.PostgreSQL.Type.Schema.Table`, `Squeal.PostgreSQL.Type.Schema.Typedef` +or `Squeal.PostgreSQL.Type.Schema.View` to be qualified by their schemas. By default, +a qualifier of @public@ is provided. + +>>> :{ +let + alias1 :: QualifiedAlias "sch" "tab" + alias1 = #sch ! #tab + alias2 :: QualifiedAlias "public" "vw" + alias2 = #vw +in printSQL alias1 >> printSQL alias2 +:} +"sch"."tab" +"vw" +-} +data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias + deriving (Eq,GHC.Generic,Ord,Show,NFData) +instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where + _ ! _ = QualifiedAlias +instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where + fromLabel = QualifiedAlias +instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) => + IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where + _ ! _ = QualifiedAlias `As` Alias +instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) => + IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where + fromLabel = QualifiedAlias `As` Alias + +instance (KnownSymbol q, KnownSymbol a) + => RenderSQL (QualifiedAlias q a) where + renderSQL _ = + let + qualifier = renderSQL (Alias @q) + alias = renderSQL (Alias @a) + in + if qualifier == "\"public\"" then alias else qualifier <> "." <> alias diff --git a/src/Squeal/PostgreSQL/Type/List.hs b/src/Squeal/PostgreSQL/Type/List.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Type/List.hs @@ -0,0 +1,204 @@ +{-| +Module: Squeal.PostgreSQL.Type.List +Description: list related types and functions +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +Haskell singly-linked lists are very powerful. This module +provides functionality for type-level lists, heterogeneous +lists and type aligned lists. +-} + +{-# LANGUAGE + DataKinds + , FlexibleContexts + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , PolyKinds + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + , UndecidableInstances +#-} + +module Squeal.PostgreSQL.Type.List + ( -- * Heterogeneous List + SOP.NP (..) + , (*:) + , one + -- * Path + , Path (..) + -- * Type Level List + , Join + , disjoin + , Additional (..) + , Elem + , In + , Length + , SubList + , SubsetList + -- * Type Level Sort + , Sort + , MergeSort + , Twos + , FoldMerge + , Merge + , MergeHelper + , MapFst + ) where + +import Control.Category.Free +import Data.Function ((&)) +import Data.Kind +import Data.Type.Bool +import GHC.TypeLits + +import Generics.SOP as SOP + +-- | `Join` is simply promoted `++` and is used in @JOIN@s in +-- `Squeal.PostgreSQL.Query.FromClause`s. +type family Join xs ys where + Join '[] ys = ys + Join (x ': xs) ys = x ': Join xs ys + +-- | `disjoin` is a utility function for splitting an `NP` list into pieces. +disjoin + :: forall xs ys expr. SListI xs + => NP expr (Join xs ys) + -> (NP expr xs, NP expr ys) +disjoin = case sList @xs of + SNil -> \ys -> (Nil, ys) + SCons -> \(x :* xsys) -> + case disjoin xsys of (xs,ys) -> (x :* xs, ys) + +-- | The `Additional` class is for appending +-- type-level list parameterized constructors such as `NP`, +-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`. +class Additional expr where + also :: expr ys -> expr xs -> expr (Join xs ys) +instance Additional (NP expr) where + also ys = \case + Nil -> ys + x :* xs -> x :* (xs & also ys) + +-- | A useful operator for ending an `NP` list of length +-- at least 2 without `Nil` +(*:) :: f x -> f y -> NP f '[x,y] +x *: y = x :* y :* Nil +infixl 8 *: + +-- | A list of length `one`. +one :: f x -> NP f '[x] +one f = f :* Nil + +-- | @Elem@ is a promoted `Data.List.elem`. +type family Elem x xs where + Elem x '[] = 'False + Elem x (x ': _) = 'True + Elem x (_ ': xs) = Elem x xs + +-- | @In x xs@ is a constraint that proves that @x@ is in @xs@. +type family In x xs :: Constraint where + In x xs = If (Elem x xs) (() :: Constraint) + (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs)) + +{- | Calculate the `Length` of a type level list + +>>> :kind! Length '[Char,String,Bool,Double] +Length '[Char,String,Bool,Double] :: Nat += 4 +-} +type family Length (xs :: [k]) :: Nat where + Length '[] = 0 + Length (_ : xs) = 1 + Length xs + +{- | `SubList` checks that one type level list is a sublist of another, +with the same ordering. + +>>> :kind! SubList '[1,2,3] '[4,5,6] +SubList '[1,2,3] '[4,5,6] :: Bool += 'False +>>> :kind! SubList '[1,2,3] '[1,2,3,4] +SubList '[1,2,3] '[1,2,3,4] :: Bool += 'True +>>> :kind! SubList '[1,2,3] '[0,1,0,2,0,3] +SubList '[1,2,3] '[0,1,0,2,0,3] :: Bool += 'True +>>> :kind! SubList '[1,2,3] '[3,2,1] +SubList '[1,2,3] '[3,2,1] :: Bool += 'False +-} +type family SubList (xs :: [k]) (ys :: [k]) :: Bool where + SubList '[] ys = 'True + SubList (x ': xs) '[] = 'False + SubList (x ': xs) (x ': ys) = SubList xs ys + SubList (x ': xs) (y ': ys) = SubList (x ': xs) ys + +{- | `SubsetList` checks that one type level list is a subset of another, +regardless of ordering and repeats. + +>>> :kind! SubsetList '[1,2,3] '[4,5,6] +SubsetList '[1,2,3] '[4,5,6] :: Bool += 'False +>>> :kind! SubsetList '[1,2,3] '[1,2,3,4] +SubsetList '[1,2,3] '[1,2,3,4] :: Bool += 'True +>>> :kind! SubsetList '[1,2,3] '[0,1,0,2,0,3] +SubsetList '[1,2,3] '[0,1,0,2,0,3] :: Bool += 'True +>>> :kind! SubsetList '[1,2,3] '[3,2,1] +SubsetList '[1,2,3] '[3,2,1] :: Bool += 'True +>>> :kind! SubsetList '[1,1,1] '[3,2,1] +SubsetList '[1,1,1] '[3,2,1] :: Bool += 'True +-} +type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where + SubsetList '[] ys = 'True + SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys + +-- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order +type Sort ls = MergeSort (Twos ls) + +-- | 'MergeSort' is the workhorse behind 'Sort' +type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where + MergeSort '[] = '[] + MergeSort '[x] = x + MergeSort ls = MergeSort (FoldMerge ls) + +-- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end) +-- It is required for implementing 'MergeSort' +type family Twos (ls :: [k]) :: [[k]] where + Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs + Twos '[x] = '[ '[x]] + Twos '[] = '[] + +-- | 'Merge' two sorted lists into one list +type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where + Merge '[] r = r + Merge l '[] = l + Merge (l ': ls) (r ': rs) = MergeHelper (l ': ls) (r ': rs) (CmpSymbol l r) + +-- | 'MergeHelper' decides whether to take an element from the right or left list next, +-- depending on the result of their comparison +type family MergeHelper (ls :: [Symbol]) (rs :: [Symbol]) (cmp :: Ordering) where + MergeHelper ls (r ': rs) 'GT = r ': Merge ls rs + MergeHelper (l ': ls) rs leq = l ': Merge ls rs + +-- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list +type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where + FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs) + FoldMerge '[x] = '[x] + FoldMerge '[] = '[] + +-- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting +-- only the names in associatve lists +type family MapFst (ls :: [(j, k)]) :: [j] where + MapFst ('(j, _) ': rest) = j ': MapFst rest + MapFst '[] = '[] diff --git a/src/Squeal/PostgreSQL/Type/PG.hs b/src/Squeal/PostgreSQL/Type/PG.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Type/PG.hs @@ -0,0 +1,346 @@ +{-| +Module: Squeal.PostgreSQL.Type.PG +Description: embedding of Haskell types into Postgres type system +Copyright: (c) Eitan Chatav, 2010 +Maintainer: eitan@morphism.tech +Stability: experimental + +Provides type families for turning Haskell `Type`s +into corresponding Postgres types. +-} +{-# LANGUAGE + AllowAmbiguousTypes + , CPP + , DeriveAnyClass + , DeriveFoldable + , DeriveFunctor + , DeriveGeneric + , DeriveTraversable + , DerivingStrategies + , DefaultSignatures + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Type.PG + ( -- * PG + IsPG (..) + , NullPG + , TuplePG + , RowPG + -- * Type families + , LabelsPG + , DimPG + , FixPG + , TupleOf + , TupleCodeOf + , RowOf + , ConstructorsOf + , ConstructorNameOf + , ConstructorNamesOf + ) where + +import Data.Aeson (Value) +import Data.Functor.Const (Const) +import Data.Functor.Constant (Constant) +import Data.Kind (Type) +import Data.Int (Int16, Int32, Int64) +#if MIN_VERSION_postgresql_binary(0, 14, 0) +import Data.IP (IPRange) +#else +import Network.IP.Addr (NetAddr, IP) +#endif +import Data.Scientific (Scientific) +import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime) +import Data.Vector (Vector) +import Data.UUID.Types (UUID) +import GHC.TypeLits + +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text as Strict (Text) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Record as SOP +import qualified Generics.SOP.Type.Metadata as Type + +import Squeal.PostgreSQL.Type +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.Schema + +-- $setup +-- >>> import Squeal.PostgreSQL +-- >>> import Data.Text (Text) +-- >>> import qualified GHC.Generics as GHC + +{- | The `PG` type family embeds a subset of Haskell types +as Postgres types. As an open type family, `PG` is extensible. + +>>> :kind! PG LocalTime +PG LocalTime :: PGType += 'PGtimestamp + +The preferred way to generate `PG`s of your own type is through +generalized newtype deriving or via deriving. + +>>> newtype UserId = UserId {getUserId :: UUID} deriving newtype IsPG + +>>> :kind! PG UserId +PG UserId :: PGType += 'PGuuid + +>>> :{ +data Answer = Yes | No + deriving stock GHC.Generic + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving IsPG via Enumerated Answer +:} + +>>> :kind! PG Answer +PG Answer :: PGType += 'PGenum '["Yes", "No"] + +>>> :{ +data Complex = Complex {real :: Double, imaginary :: Double} + deriving stock GHC.Generic + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving IsPG via Composite Complex +:} + +>>> :kind! PG Complex +PG Complex :: PGType += 'PGcomposite + '["real" ::: 'NotNull 'PGfloat8, + "imaginary" ::: 'NotNull 'PGfloat8] +-} +class IsPG (hask :: Type) where type PG hask :: PGType +-- | `PGbool` +instance IsPG Bool where type PG Bool = 'PGbool +-- | `PGint2` +instance IsPG Int16 where type PG Int16 = 'PGint2 +-- | `PGint4` +instance IsPG Int32 where type PG Int32 = 'PGint4 +-- | `PGint8` +instance IsPG Int64 where type PG Int64 = 'PGint8 +-- | `PGint2` +instance IsPG LibPQ.Oid where type PG LibPQ.Oid = 'PGoid +-- | `PGnumeric` +instance IsPG Scientific where type PG Scientific = 'PGnumeric +-- | `PGfloat4` +instance IsPG Float where type PG Float = 'PGfloat4 +-- | `PGfloat8` +instance IsPG Double where type PG Double = 'PGfloat8 +-- | `PGchar` @1@ +instance IsPG Char where type PG Char = 'PGchar 1 +-- | `PGtext` +instance IsPG Strict.Text where type PG Strict.Text = 'PGtext +-- | `PGtext` +instance IsPG Lazy.Text where type PG Lazy.Text = 'PGtext +-- | `PGtext` +instance IsPG String where type PG String = 'PGtext +-- | `PGbytea` +instance IsPG Strict.ByteString where type PG Strict.ByteString = 'PGbytea +-- | `PGbytea` +instance IsPG Lazy.ByteString where type PG Lazy.ByteString = 'PGbytea +-- | `PGtimestamp` +instance IsPG LocalTime where type PG LocalTime = 'PGtimestamp +-- | `PGtimestamptz` +instance IsPG UTCTime where type PG UTCTime = 'PGtimestamptz +-- | `PGdate` +instance IsPG Day where type PG Day = 'PGdate +-- | `PGtime` +instance IsPG TimeOfDay where type PG TimeOfDay = 'PGtime +-- | `PGtimetz` +instance IsPG (TimeOfDay, TimeZone) where type PG (TimeOfDay, TimeZone) = 'PGtimetz +-- | `PGinterval` +instance IsPG DiffTime where type PG DiffTime = 'PGinterval +-- | `PGuuid` +instance IsPG UUID where type PG UUID = 'PGuuid +-- | `PGinet` +#if MIN_VERSION_postgresql_binary(0, 14, 0) +instance IsPG IPRange where type PG IPRange = 'PGinet +#else +instance IsPG (NetAddr IP) where type PG (NetAddr IP) = 'PGinet +#endif +-- | `PGjson` +instance IsPG Value where type PG Value = 'PGjson +-- | `PGvarchar` +instance IsPG (VarChar n) where type PG (VarChar n) = 'PGvarchar n +-- | `PGvarchar` +instance IsPG (FixChar n) where type PG (FixChar n) = 'PGchar n +-- | `PG hask` +instance IsPG hask => IsPG (Const hask tag) where type PG (Const hask tag) = PG hask +-- | `PG hask` +instance IsPG hask => IsPG (SOP.K hask tag) where type PG (SOP.K hask tag) = PG hask +-- | `PG hask` +instance IsPG hask => IsPG (Constant hask tag) where type PG (Constant hask tag) = PG hask + +-- | `PGmoney` +instance IsPG Money where type PG Money = 'PGmoney +-- | `PGjson` +instance IsPG (Json hask) where type PG (Json hask) = 'PGjson +-- | `PGjsonb` +instance IsPG (Jsonb hask) where type PG (Jsonb hask) = 'PGjsonb +-- | `PGcomposite` @(@`RowPG` @hask)@ +instance IsPG (Composite hask) where + type PG (Composite hask) = 'PGcomposite (RowPG hask) +-- | `PGenum` @(@`LabelsPG` @hask)@ +instance IsPG (Enumerated hask) where + type PG (Enumerated hask) = 'PGenum (LabelsPG hask) +-- | `PGvararray` @(@`NullPG` @x)@ +instance IsPG (VarArray (Vector x)) where + type PG (VarArray (Vector x)) = 'PGvararray (NullPG x) +-- | `PGvararray` @(@`NullPG` @x)@ +instance IsPG (VarArray [x]) where + type PG (VarArray [x]) = 'PGvararray (NullPG x) +-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@ +instance IsPG (FixArray hask) where + type PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask) + +{-| The `LabelsPG` type family calculates the constructors of a +Haskell enum type. + +>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +>>> instance SOP.Generic Schwarma +>>> instance SOP.HasDatatypeInfo Schwarma +>>> :kind! LabelsPG Schwarma +LabelsPG Schwarma :: [Type.ConstructorName] += '["Beef", "Lamb", "Chicken"] +-} +type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where + LabelsPG hask = + ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask)) + +{- | +`RowPG` turns a Haskell `Type` into a `RowType`. + +`RowPG` may be applied to normal Haskell record types provided they +have `SOP.Generic` and `SOP.HasDatatypeInfo` instances; + +>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic +>>> instance SOP.Generic Person +>>> instance SOP.HasDatatypeInfo Person +>>> :kind! RowPG Person +RowPG Person :: [(Symbol, NullType)] += '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4] +-} +type family RowPG (hask :: Type) :: RowType where + RowPG hask = RowOf (SOP.RecordCodeOf hask) + +-- | `RowOf` applies `NullPG` to the fields of a list. +type family RowOf (record :: [(Symbol, Type)]) :: RowType where + RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record + RowOf '[] = '[] + +{- | `NullPG` turns a Haskell type into a `NullType`. + +>>> :kind! NullPG Double +NullPG Double :: NullType += 'NotNull 'PGfloat8 +>>> :kind! NullPG (Maybe Double) +NullPG (Maybe Double) :: NullType += 'Null 'PGfloat8 +-} +type family NullPG (hask :: Type) :: NullType where + NullPG (Maybe hask) = 'Null (PG hask) + NullPG hask = 'NotNull (PG hask) + +{- | `TuplePG` turns a Haskell tuple type (including record types) into +the corresponding list of `NullType`s. + +>>> :kind! TuplePG (Double, Maybe Char) +TuplePG (Double, Maybe Char) :: [NullType] += '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)] +-} +type family TuplePG (hask :: Type) :: [NullType] where + TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask)) + +-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullType`s. +type family TupleOf (tuple :: [Type]) :: [NullType] where + TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple + TupleOf '[] = '[] + +-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type` +-- and if it's a simple product returns it, otherwise giving a `TypeError`. +type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where + TupleCodeOf hask '[tuple] = tuple + TupleCodeOf hask '[] = + TypeError + ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type." + ':$$: 'Text "It is a void type with no constructors." + ) + TupleCodeOf hask (_ ': _ ': _) = + TypeError + ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type." + ':$$: 'Text "It is a sum type with more than one constructor." + ) + +-- | Calculates constructors of a datatype. +type family ConstructorsOf (datatype :: Type.DatatypeInfo) + :: [Type.ConstructorInfo] where + ConstructorsOf ('Type.ADT _module _datatype constructors _strictness) = + constructors + ConstructorsOf ('Type.Newtype _module _datatype constructor) = + '[constructor] + +-- | Calculates the name of a nullary constructor, otherwise +-- generates a type error. +type family ConstructorNameOf (constructor :: Type.ConstructorInfo) + :: Type.ConstructorName where + ConstructorNameOf ('Type.Constructor name) = name + ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError + ('Text "ConstructorNameOf error: non-nullary constructor " + ':<>: 'Text name) + ConstructorNameOf ('Type.Record name _fields) = TypeError + ('Text "ConstructorNameOf error: non-nullary constructor " + ':<>: 'Text name) + +-- | Calculate the names of nullary constructors. +type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo]) + :: [Type.ConstructorName] where + ConstructorNamesOf '[] = '[] + ConstructorNamesOf (constructor ': constructors) = + ConstructorNameOf constructor ': ConstructorNamesOf constructors + +-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths, +-- up to a depth of 10 for each dimension. +type family DimPG (hask :: Type) :: [Nat] where + DimPG (x,x) = 2 ': DimPG x + DimPG (x,x,x) = 3 ': DimPG x + DimPG (x,x,x,x) = 4 ': DimPG x + DimPG (x,x,x,x,x) = 5 ': DimPG x + DimPG (x,x,x,x,x,x) = 6 ': DimPG x + DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x + DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x + DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x + DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x + DimPG x = '[] + +-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples, +-- up to a depth of 10 for each dimension. +type family FixPG (hask :: Type) :: NullType where + FixPG (x,x) = FixPG x + FixPG (x,x,x) = FixPG x + FixPG (x,x,x,x) = FixPG x + FixPG (x,x,x,x,x) = FixPG x + FixPG (x,x,x,x,x,x) = FixPG x + FixPG (x,x,x,x,x,x,x) = FixPG x + FixPG (x,x,x,x,x,x,x,x) = FixPG x + FixPG (x,x,x,x,x,x,x,x,x) = FixPG x + FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x + FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x + FixPG x = NullPG x diff --git a/src/Squeal/PostgreSQL/Type/Schema.hs b/src/Squeal/PostgreSQL/Type/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/PostgreSQL/Type/Schema.hs @@ -0,0 +1,842 @@ +{-| +Module: Squeal.PostgreSQL.Type.Schema +Description: Postgres type system +Copyright: (c) Eitan Chatav, 2019 +Maintainer: eitan@morphism.tech +Stability: experimental + +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. +-} + +{-# LANGUAGE + AllowAmbiguousTypes + , ConstraintKinds + , DeriveAnyClass + , DeriveGeneric + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , OverloadedStrings + , QuantifiedConstraints + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeFamilyDependencies + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances + , UndecidableSuperClasses +#-} + +module Squeal.PostgreSQL.Type.Schema + ( -- * Postgres Type + PGType (..) + , NullType (..) + , RowType + , FromType + -- * Schema Type + , ColumnType + , ColumnsType + , TableType + , SchemumType (..) + , IndexType (..) + , FunctionType + , ReturnsType (..) + , SchemaType + , SchemasType + , Public + -- * Database Subsets + , SubDB + , SubsetDB + , ElemDB + -- * Constraint + , (:=>) + , Optionality (..) + , TableConstraint (..) + , TableConstraints + , Uniquely + -- * Enumerated Label + , IsPGlabel (..) + , PGlabel (..) + -- * Data Definition + , Create + , CreateIfNotExists + , CreateOrReplace + , Drop + , DropSchemum + , DropIfExists + , DropSchemumIfExists + , Alter + , AlterIfExists + , Rename + , RenameIfExists + , SetSchema + , ConstraintInvolves + , DropIfConstraintsInvolve + -- * Type Classification + , PGNum + , PGIntegral + , PGFloating + , PGJsonType + , PGJsonKey + , SamePGType + , AllNotNull + , NotAllNull + -- * Nullification + , NullifyType + , NullifyRow + , NullifyFrom + -- * Table Conversion + , TableToColumns + , ColumnsToRow + , TableToRow + -- * Updatable + , Updatable + , AllUnique + , IsNotElem + -- * User Type Lookup + , DbEnums + , SchemaEnums + , DbRelations + , SchemaRelations + , FindQualified + , FindName + , FindNamespace + -- * Schema Error Printing + , PrettyPrintPartitionedSchema + , PartitionedSchema(..) + , PartitionSchema + , SchemaFunctions + , SchemaIndexes + , SchemaProcedures + , SchemaTables + , SchemaTypes + , SchemaUnsafes + , SchemaViews + , IntersperseNewlines + , FilterNonEmpty + , FieldIfNonEmpty + , PartitionSchema' + ) where + +import Control.Category +import Data.Kind +import Data.Monoid hiding (All) +import Data.Type.Bool +import Generics.SOP +import GHC.TypeLits +import Prelude hiding (id, (.)) + +import Squeal.PostgreSQL.Type.Alias +import Squeal.PostgreSQL.Type.List +import Squeal.PostgreSQL.Render + +-- $setup +-- >>> import Squeal.PostgreSQL + +-- | `PGType` is the promoted datakind of PostgreSQL types. +-- +-- >>> :kind 'PGbool +-- 'PGbool :: PGType +data PGType + = PGbool -- ^ logical Boolean (true/false) + | PGint2 -- ^ signed two-byte integer + | PGint4 -- ^ signed four-byte integer + | PGint8 -- ^ signed eight-byte integer + | PGnumeric -- ^ arbitrary precision numeric type + | PGfloat4 -- ^ single precision floating-point number (4 bytes) + | PGfloat8 -- ^ double precision floating-point number (8 bytes) + | PGmoney -- ^ currency amount + | PGchar Nat -- ^ fixed-length character string + | PGvarchar Nat -- ^ variable-length character string + | PGtext -- ^ variable-length character string + | PGbytea -- ^ binary data ("byte array") + | PGtimestamp -- ^ date and time (no time zone) + | PGtimestamptz -- ^ date and time, including time zone + | PGdate -- ^ calendar date (year, month, day) + | PGtime -- ^ time of day (no time zone) + | PGtimetz -- ^ time of day, including time zone + | PGinterval -- ^ time span + | PGuuid -- ^ universally unique identifier + | PGinet -- ^ IPv4 or IPv6 host address + | PGjson -- ^ textual JSON data + | PGjsonb -- ^ binary JSON data, decomposed + | PGvararray NullType -- ^ variable length array + | PGfixarray [Nat] NullType -- ^ fixed length array + | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values. + | 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. + | 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 + +-- | `NullType` encodes the potential presence or definite absence of a +-- @NULL@ allowing operations which are sensitive to such to be well typed. +-- +-- >>> :kind 'Null 'PGint4 +-- 'Null 'PGint4 :: NullType +-- >>> :kind 'NotNull ('PGvarchar 50) +-- 'NotNull ('PGvarchar 50) :: NullType +data NullType + = Null PGType -- ^ @NULL@ may be present + | NotNull PGType -- ^ @NULL@ is absent + +-- | The constraint operator, `:=>` is a type level pair +-- between a "constraint" and some type, for use in pairing +-- an `Optionality` with a `NullType` to produce a `ColumnType` +-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`. +type (:=>) constraint ty = '(constraint,ty) +infixr 7 :=> + +-- | `Optionality` encodes the availability of @DEFAULT@ for inserts and updates. +-- A column can be assigned a default value. +-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also +-- request explicitly that a column be set to its default value, +-- without having to know what that value is. +data Optionality + = Def -- ^ @DEFAULT@ is available for inserts and updates + | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates + +-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the +-- base `PGType` for a column. +-- +-- >>> :set -XTypeFamilies -XDataKinds -XPolyKinds +-- >>> import GHC.TypeLits +-- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4 +-- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext +type ColumnType = (Optionality,NullType) + +-- | `ColumnsType` is a row of `ColumnType`s. +-- +-- >>> :{ +-- type family UsersColumns :: ColumnsType where +-- UsersColumns = +-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext +-- , "id" ::: 'Def :=> 'NotNull 'PGint4 +-- ] +-- :} +type ColumnsType = [(Symbol,ColumnType)] + +type instance PrettyPrintHaystack (haystack :: ColumnsType) = + 'PrettyPrintInfo ('Text "column definition (ColumnType)") ('Text "table (ColumnsType)") ('ShowType (Sort (MapFst haystack))) + +-- | `TableConstraint` encodes various forms of data constraints +-- of columns in a table. +-- `TableConstraint`s give you as much control over the data in your tables +-- as you wish. If a user attempts to store data in a column that would +-- violate a constraint, an error is raised. This applies +-- even if the value came from the default value definition. +data TableConstraint + = Check [Symbol] + | Unique [Symbol] + | PrimaryKey [Symbol] + | ForeignKey [Symbol] Symbol Symbol [Symbol] + +{- | A `TableConstraints` is a row of `TableConstraint`s. + +>>> :{ +type family UsersConstraints :: TableConstraints where + UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] +:} +-} +type TableConstraints = [(Symbol,TableConstraint)] + +type instance PrettyPrintHaystack (haystack :: TableConstraints) = + 'PrettyPrintInfo ('Text "constraint (TableConstraint)") ('Text "table (TableConstraints)") ('ShowType (Sort (MapFst haystack))) + +-- | A `ForeignKey` must reference columns that either are +-- a `PrimaryKey` or form a `Unique` constraint. +type family Uniquely + (key :: [Symbol]) + (constraints :: TableConstraints) :: Constraint where + Uniquely key (uq ::: 'Unique key ': constraints) = () + Uniquely key (pk ::: 'PrimaryKey key ': constraints) = () + Uniquely key (_ ': constraints) = Uniquely key constraints + +-- | `TableType` encodes a row of constraints on a table as well as the types +-- of its columns. +-- +-- >>> :{ +-- type family UsersTable :: TableType where +-- UsersTable = +-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> +-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 +-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext +-- ] +-- :} +type TableType = (TableConstraints,ColumnsType) + +{- | 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. + +>>> :{ +type family PersonRow :: RowType where + PersonRow = + '[ "name" ::: 'NotNull 'PGtext + , "age" ::: 'NotNull 'PGint4 + , "dateOfBirth" ::: 'Null 'PGdate + ] +:} +-} +type RowType = [(Symbol,NullType)] + +type instance PrettyPrintHaystack (haystack :: RowType) = + 'PrettyPrintInfo ('Text "column (NullType)") ('Text "row (RowType)") ('ShowType (Sort (MapFst haystack))) + +{- | `FromType` is a row of `RowType`s. It can be thought of as +a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.From.FromClause`s +and `Squeal.PostgreSQL.Query.Table.TableExpression`s. +-} +type FromType = [(Symbol,RowType)] + +type instance PrettyPrintHaystack (haystack :: FromType) = + 'PrettyPrintInfo ('Text "row (RowType)") ('Text "from clause (FromType)") ('ShowType (Sort (MapFst haystack))) + +-- | `ColumnsToRow` removes column constraints. +type family ColumnsToRow (columns :: ColumnsType) :: RowType where + ColumnsToRow (column ::: _ :=> ty ': columns) = + column ::: ty ': ColumnsToRow columns + ColumnsToRow '[] = '[] + +-- | `TableToColumns` removes table constraints. +type family TableToColumns (table :: TableType) :: ColumnsType where + TableToColumns (constraints :=> columns) = columns + +-- | Convert a table to a row type. +type family TableToRow (table :: TableType) :: RowType where + TableToRow tab = ColumnsToRow (TableToColumns tab) + +-- | Numeric Postgres types. +type PGNum = + '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8] + +-- | Floating Postgres types. +type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric] + +-- | Integral Postgres types. +type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8] + +-- | Equality constraint on the underlying `PGType` of two columns. +class SamePGType + (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where +instance ty0 ~ ty1 => SamePGType + (alias0 ::: def0 :=> null0 ty0) + (alias1 ::: def1 :=> null1 ty1) + +-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. +type family AllNotNull (columns :: ColumnsType) :: Constraint where + AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns + AllNotNull '[] = () + +-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some +-- @NOT NULL@. +type family NotAllNull (columns :: ColumnsType) :: Constraint where + NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = () + NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns + +-- | `NullifyType` is an idempotent that nullifies a `NullType`. +type family NullifyType (ty :: NullType) :: NullType where + NullifyType (null ty) = 'Null ty + +-- | `NullifyRow` is an idempotent that nullifies a `RowType`. +type family NullifyRow (columns :: RowType) :: RowType where + NullifyRow (column ::: ty ': columns) = + column ::: NullifyType ty ': NullifyRow columns + NullifyRow '[] = '[] + +-- | `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.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.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 + ('Text "Create: alias " + ':<>: 'ShowType alias + ':<>: 'Text "already exists") + Create alias y (x ': xs) = x ': Create alias y xs + +{-| Similar to `Create` but no error on pre-existence-} +type family CreateIfNotExists alias x xs where + CreateIfNotExists alias x '[] = '[alias ::: x] + CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs + CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs + +{-| Similar to `Create` but used to replace values +with the same type.-} +type family CreateOrReplace alias x xs where + CreateOrReplace alias x '[] = '[alias ::: x] + CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs + CreateOrReplace alias x (alias ::: y ': xs) = TypeError + ('Text "CreateOrReplace: expected type " + ':<>: 'ShowType x + ':<>: 'Text " but alias " + ':<>: 'ShowType alias + ':<>: 'Text " has type " + ':<>: 'ShowType y) + CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs + +-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@ +-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements +-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements. +type family Drop alias xs where + Drop alias '[] = TypeError + ('Text "Drop: alias " + ':<>: 'ShowType alias + ':<>: 'Text " does not exist" ) + Drop alias (alias ::: x ': xs) = xs + Drop alias (x ': xs) = x ': Drop alias xs + +-- | Drop a particular flavor of schemum type +type family DropSchemum alias sch xs where + DropSchemum alias sch '[] = TypeError + ('Text "DropSchemum: alias " + ':<>: 'ShowType alias + ':<>: 'Text " does not exist" ) + DropSchemum alias sch (alias ::: sch x ': xs) = xs + DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError + ('Text "DropSchemum: expected schemum " + ':<>: 'ShowType sch0 + ':<>: 'Text " but alias " + ':<>: 'ShowType alias + ':<>: 'Text " has schemum " + ':<>: 'ShowType sch1) + DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs + +-- | Similar to `Drop` but no error on non-existence +type family DropIfExists alias xs where + DropIfExists alias '[] = '[] + DropIfExists alias (alias ::: x ': xs) = xs + DropIfExists alias (x ': xs) = x ': DropIfExists alias xs + +-- | Similar to `DropSchemum` but no error on non-existence +type family DropSchemumIfExists alias sch xs where + DropSchemumIfExists alias sch '[] = '[] + DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs + DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError + ('Text "DropSchemumIfExists: expected schemum " + ':<>: 'ShowType sch1 + ':<>: 'Text " but alias " + ':<>: 'ShowType alias + ':<>: 'Text " has schemum " + ':<>: 'ShowType sch0) + DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs + +-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@ +-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable` +-- and `Squeal.PostgreSQL.Definition.alterColumn`. +type family Alter alias x xs where + Alter alias x '[] = TypeError + ('Text "Alter: alias " + ':<>: 'ShowType alias + ':<>: 'Text " does not exist" ) + Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs + Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs + +-- | Similar to `Alter` but no error on non-existence +type family AlterIfExists alias x xs where + AlterIfExists alias x '[] = '[] + AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs + AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs + +-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@ +-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and +-- `Squeal.PostgreSQL.Definition.renameColumn`. +type family Rename alias0 alias1 xs where + Rename alias0 alias1 '[] = TypeError + ('Text "Rename: alias " + ':<>: 'ShowType alias0 + ':<>: 'Text " does not exist" ) + Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs + Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs + +-- | Similar to `Rename` but no error on non-existence +type family RenameIfExists alias0 alias1 xs where + RenameIfExists alias x '[] = '[] + 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) + +{- | `SubDB` checks that one `SchemasType` is a sublist of another, +with the same ordering. + +>>> :kind! SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]] +SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]] :: Bool += 'True +-} +type family SubDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where + SubDB '[] db1 = 'True + SubDB (sch ': db0) '[] = 'False + SubDB (sch ::: schema0 ': db0) (sch ::: schema1 ': db1) = + If (SubList schema0 schema1) + (SubDB db0 db1) + (SubDB (sch ::: schema0 ': db0) db1) + SubDB db0 (sch1 ': db1) = SubDB db0 db1 + +{- | `SubsetDB` checks that one `SchemasType` is a subset of another, +regardless of ordering. + +>>> :kind! SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]] +SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]] :: Bool += 'True +-} +type family SubsetDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where + SubsetDB '[] db1 = 'True + SubsetDB (sch ': db0) db1 = ElemDB sch db1 && SubsetDB db0 db1 + +{- | `ElemDB` checks that a schema may be found as a subset of another in a database, +regardless of ordering. +-} +type family ElemDB (sch :: (Symbol, SchemaType)) (db :: SchemasType) :: Bool where + ElemDB sch '[] = 'False + ElemDB (sch ::: schema0) (sch ::: schema1 ': _) = SubsetList schema0 schema1 + ElemDB sch (_ ': schs) = ElemDB sch schs + +-- | Check if a `TableConstraint` involves a column +type family ConstraintInvolves column constraint where + ConstraintInvolves column ('Check columns) = column `Elem` columns + ConstraintInvolves column ('Unique columns) = column `Elem` columns + ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns + ConstraintInvolves column ('ForeignKey columns sch tab refcolumns) + = column `Elem` columns + +-- | Drop all `TableConstraint`s that involve a column +type family DropIfConstraintsInvolve column constraints where + DropIfConstraintsInvolve column '[] = '[] + DropIfConstraintsInvolve column (alias ::: constraint ': constraints) + = If (ConstraintInvolves column constraint) + (DropIfConstraintsInvolve column constraints) + (alias ::: constraint ': DropIfConstraintsInvolve column constraints) + +-- | A `SchemumType` is a user-created type, like a `Table`, +-- `View` or `Typedef`. +data SchemumType + = Table TableType + | View RowType + | Typedef PGType + | Index IndexType + | Function FunctionType + | Procedure [NullType] + | UnsafeSchemum Symbol + +{- | 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) + +{- | +PostgreSQL provides several index types: +B-tree, Hash, GiST, SP-GiST, GIN and BRIN. +Each index type uses a different algorithm +that is best suited to different types of queries. +-} +data IndexType + = Btree + -- ^ B-trees can handle equality and range queries on data + -- that can be sorted into some ordering. + | Hash + -- ^ Hash indexes can only handle simple equality comparisons. + | Gist + -- ^ GiST indexes are not a single kind of index, + -- but rather an infrastructure within which many different + -- indexing strategies can be implemented. + | Spgist + -- ^ SP-GiST indexes, like GiST indexes, + -- offer an infrastructure that supports various kinds of searches. + | Gin + -- ^ GIN indexes are “inverted indexes” which are appropriate for + -- data values that contain multiple component values, such as arrays. + | Brin + -- ^ BRIN indexes (a shorthand for Block Range INdexes) store summaries + -- about the values stored in consecutive physical block ranges of a table. + +{- | Return type of a function-} +data ReturnsType + = Returns NullType -- ^ function + | ReturnsTable RowType -- ^ set returning function + +{- | A schema of a database consists of a list of aliased, +user-defined `SchemumType`s. + +>>> :{ +type family Schema :: SchemaType where + Schema = + '[ "users" ::: 'Table ( + '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ]) + , "emails" ::: 'Table ( + '[ "pk_emails" ::: 'PrimaryKey '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ]) + ] +:} +-} +type SchemaType = [(Symbol,SchemumType)] + +-- | A @PartitionedSchema@ is a @SchemaType@ where each constructor of @SchemumType@ has +-- been separated into its own list +data PartitionedSchema = PartitionedSchema + { _tables :: [(Symbol, TableType)] + , _views :: [(Symbol, RowType)] + , _types :: [(Symbol, PGType)] + , _indexes :: [(Symbol, IndexType)] + , _functions :: [(Symbol, FunctionType)] + , _procedures :: [(Symbol, [NullType])] + , _unsafes :: [(Symbol, Symbol)] + } + +-- | @PartitionSchema@ partitions a @SchemaType@ into a @PartitionedSchema@ +type PartitionSchema schema = PartitionSchema' schema ('PartitionedSchema '[] '[] '[] '[] '[] '[] '[]) + +-- | Utility type family for `PartitionSchema`. +type family PartitionSchema' (remaining :: SchemaType) (acc :: PartitionedSchema) :: PartitionedSchema where + PartitionSchema' '[] ps = ps + PartitionSchema' ('(s, 'Table table) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema ('(s, table) ': tables) views types indexes functions procedures unsafe) + PartitionSchema' ('(s, 'View view) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables ('(s, view) ': views) types indexes functions procedures unsafe) + PartitionSchema' ('(s, 'Typedef typ) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views ('(s, typ) ': types) indexes functions procedures unsafe) + PartitionSchema' ('(s, 'Index ix) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types ('(s, ix) ': indexes) functions procedures unsafe) + PartitionSchema' ('(s, 'Function f) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes ('(s, f) ': functions) procedures unsafe) + PartitionSchema' ('(s, 'Procedure p) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions ('(s, p) ': procedures) unsafe) + PartitionSchema' ('(s, 'UnsafeSchemum u) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions procedures ('(s, u) ': unsafe)) + +-- | Get the tables from a @PartitionedSchema@ +type family SchemaTables (schema :: PartitionedSchema) :: [(Symbol, TableType)] where + SchemaTables ('PartitionedSchema tables _ _ _ _ _ _) = tables +-- | Get the views from a @PartitionedSchema@ +type family SchemaViews (schema :: PartitionedSchema) :: [(Symbol, RowType)] where + SchemaViews ('PartitionedSchema _ views _ _ _ _ _) = views +-- | Get the typedefs from a @PartitionedSchema@ +type family SchemaTypes (schema :: PartitionedSchema) :: [(Symbol, PGType)] where + SchemaTypes ('PartitionedSchema _ _ types _ _ _ _) = types +-- | Get the indexes from a @PartitionedSchema@ +type family SchemaIndexes (schema :: PartitionedSchema) :: [(Symbol, IndexType)] where + SchemaIndexes ('PartitionedSchema _ _ _ indexes _ _ _) = indexes +-- | Get the functions from a @PartitionedSchema@ +type family SchemaFunctions (schema :: PartitionedSchema) :: [(Symbol, FunctionType)] where + SchemaFunctions ('PartitionedSchema _ _ _ _ functions _ _) = functions +-- | Get the procedured from a @PartitionedSchema@ +type family SchemaProcedures (schema :: PartitionedSchema) :: [(Symbol, [NullType])] where + SchemaProcedures ('PartitionedSchema _ _ _ _ _ procedures _) = procedures +-- | Get the unsafe schema types from a @PartitionedSchema@ +type family SchemaUnsafes (schema :: PartitionedSchema) :: [(Symbol, Symbol)] where + SchemaUnsafes ('PartitionedSchema _ _ _ _ _ _ unsafes) = unsafes + +-- | @PrettyPrintPartitionedSchema@ makes a nice @ErrorMessage@ showing a @PartitionedSchema@, +-- only including the names of the things in it and not the values. Additionally, empty +-- fields are omitted +type family PrettyPrintPartitionedSchema (schema :: PartitionedSchema) :: ErrorMessage where + PrettyPrintPartitionedSchema schema = IntersperseNewlines (FilterNonEmpty + [ FieldIfNonEmpty "Tables" (SchemaTables schema) + , FieldIfNonEmpty "Views" (SchemaViews schema) + , FieldIfNonEmpty "Types" (SchemaTypes schema) + , FieldIfNonEmpty "Indexes" (SchemaIndexes schema) + , FieldIfNonEmpty "Functions" (SchemaFunctions schema) + , FieldIfNonEmpty "Procedures" (SchemaProcedures schema) + , FieldIfNonEmpty "Unsafe schema items" (SchemaUnsafes schema) + ]) + +-- | Print field name (if corresponding values are non-empty). +type family FieldIfNonEmpty (fieldName :: Symbol) (value :: [(Symbol, k)]) :: ErrorMessage where + FieldIfNonEmpty _ '[] = 'Text "" + FieldIfNonEmpty n xs = 'Text " " ':<>: 'Text n ':<>: 'Text ":" ':$$: 'Text " " ':<>: 'ShowType (Sort (MapFst xs)) + +-- | Filter out empty error messages. +type family FilterNonEmpty (ls :: [ErrorMessage]) :: [ErrorMessage] where + FilterNonEmpty ('Text "" ': rest) = FilterNonEmpty rest + FilterNonEmpty (x ': rest) = x ': FilterNonEmpty rest + FilterNonEmpty '[] = '[] + +-- | Vertically concatenate error messages. +type family IntersperseNewlines (ls :: [ErrorMessage]) :: ErrorMessage where + IntersperseNewlines (x ': y ': '[]) = x ':$$: y + IntersperseNewlines (x ': xs) = x ':$$: IntersperseNewlines xs + IntersperseNewlines '[] = 'Text "" + +type instance PrettyPrintHaystack (haystack :: SchemaType) = + 'PrettyPrintInfo ('Text "table, view, typedef, index, function, or procedure (SchemumType)") ('Text "schema (SchemaType)") + ( PrettyPrintPartitionedSchema (PartitionSchema haystack) + ) + +{- | +A database contains one or more named schemas, which in turn contain tables. +The same object name can be used in different schemas without conflict; +for example, both schema1 and myschema can contain tables named mytable. +Unlike databases, schemas are not rigidly separated: +a user can access objects in any of the schemas in the database they are connected to, +if they have privileges to do so. + +There are several reasons why one might want to use schemas: + + * To allow many users to use one database without interfering with each other. + * To organize database objects into logical groups to make them more manageable. + * Third-party applications can be put into separate schemas + so they do not collide with the names of other objects. +-} +type SchemasType = [(Symbol,SchemaType)] + +type instance PrettyPrintHaystack (haystack :: SchemasType) = + 'PrettyPrintInfo ('Text "schema (SchemaType)") ('Text "database (SchemasType)") ('Text " " ':<>: 'ShowType (Sort (MapFst haystack))) + +-- | A type family to use for a single schema database. +type family Public (schema :: SchemaType) :: SchemasType + where Public schema = '["public" ::: schema] + +-- | `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". +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 +instance {-# OVERLAPPING #-} + IsPGlabel label0 (NS PGlabel (label0 ': labels)) where + label = Z PGlabel +instance {-# OVERLAPPABLE #-} IsPGlabel label0 (NS PGlabel labels) + => IsPGlabel label0 (NS PGlabel (label1 ': labels)) where + label = S (label @label0) +-- | A `PGlabel` unit type with an `IsPGlabel` instance +data PGlabel (label :: Symbol) = PGlabel +instance KnownSymbol label => RenderSQL (PGlabel label) where + renderSQL _ = "\'" <> renderSymbol @label <> "\'" +instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where + renderSQL + = commaSeparated + . hcollapse + . hcmap (Proxy @KnownSymbol) (K . renderSQL) + +-- | Is a type a valid JSON key? +type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ] + +-- | Is a type a valid JSON type? +type PGJsonType = '[ 'PGjson, 'PGjsonb ] + +-- | Utility class for `AllUnique` to provide nicer error messages. +class IsNotElem x isElem where +instance IsNotElem x 'False where +instance (TypeError ( 'Text "Cannot assign to " + ':<>: 'ShowType alias + ':<>: 'Text " more than once")) + => IsNotElem '(alias, a) 'True where + +-- | No elem of @xs@ appears more than once, in the context of assignment. +class AllUnique (xs :: [(Symbol, a)]) where +instance AllUnique '[] where +instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where + +-- | Updatable lists of columns +type Updatable table columns = + ( All (HasIn (TableToColumns table)) columns + , AllUnique columns + , SListI (TableToColumns table) ) + +{- | Filters a schema down to labels of all enum typedefs. +-} +type family SchemaEnums schema where + SchemaEnums '[] = '[] + SchemaEnums (enum ::: 'Typedef ('PGenum labels) ': schema) = + enum ::: labels ': SchemaEnums schema + SchemaEnums (_ ': schema) = SchemaEnums schema + +{- | Filters schemas down to labels of all enum typedefs. +-} +type family DbEnums db where + DbEnums '[] = '[] + DbEnums (sch ::: schema ': schemas) = + sch ::: SchemaEnums schema ': DbEnums schemas + +{- | Filters a schema down to rows of relations; +all composites, tables and views. +-} +type family SchemaRelations schema where + SchemaRelations '[] = '[] + SchemaRelations (ty ::: 'Typedef ('PGcomposite row) ': schema) = + ty ::: row ': SchemaRelations schema + SchemaRelations (tab ::: 'Table table ': schema) = + tab ::: TableToRow table ': SchemaRelations schema + SchemaRelations (vw ::: 'View row ': schema) = + vw ::: row ': SchemaRelations schema + SchemaRelations (_ ': schema) = SchemaRelations schema + +{- | Filters schemas down to rows of relations; +all composites, tables and views. +-} +type family DbRelations db where + DbRelations '[] = '[] + DbRelations (sch ::: schema ': schemas) = + sch ::: SchemaRelations schema ': DbRelations schemas + +-- | Used in `FindQualified` +type family FindName xs x where + FindName '[] xs = 'Nothing + FindName ( '(name, x) ': _) x = 'Just name + FindName (_ ': xs) x = FindName xs x + +-- | Used in `FindQualified` +type family FindNamespace err nsp name xss x where + FindNamespace err _ 'Nothing xss x = FindQualified err xss x + FindNamespace _ nsp ('Just name) _ _ = '(nsp, name) + +{- | Find fully qualified name with a type error if lookup fails. +This is used to find the qualified name of a user defined type. + +>>> :kind! FindQualified "my error message:" +FindQualified "my error message:" :: [(k1, [(k2, k3)])] + -> k3 -> (k1, k2) += FindQualified "my error message:" + +>>> :kind! FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Double +FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Double :: (Symbol, + Symbol) += '("foo", "bar") + +>>> :kind! FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Bool +FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Bool :: (Symbol, + Symbol) += (TypeError ...) +-} +type family FindQualified err xss x where + FindQualified err '[] x = TypeError + ('Text err ':$$: 'ShowType x) + FindQualified err ( '(nsp, xs) ': xss) x = + FindNamespace err nsp (FindName xs x) xss x diff --git a/test/Doc.hs b/test/Doc.hs new file mode 100644 --- /dev/null +++ b/test/Doc.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest [ "-isrc", "src" ] diff --git a/test/DocTest.hs b/test/DocTest.hs deleted file mode 100644 --- a/test/DocTest.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Main (main) where - -import Test.DocTest - -main :: IO () -main = doctest - [ "-isrc" - , "src/Squeal/PostgreSQL.hs" - , "src/Squeal/PostgreSQL/Binary.hs" - , "src/Squeal/PostgreSQL/Definition.hs" - , "src/Squeal/PostgreSQL/Manipulation.hs" - , "src/Squeal/PostgreSQL/Query.hs" - , "src/Squeal/PostgreSQL/Expression.hs" - , "src/Squeal/PostgreSQL/PQ.hs" - , "src/Squeal/PostgreSQL/Migration.hs" - , "src/Squeal/PostgreSQL/Transaction.hs" - , "src/Squeal/PostgreSQL/Pool.hs" - ] diff --git a/test/Property.hs b/test/Property.hs new file mode 100644 --- /dev/null +++ b/test/Property.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE + DataKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeOperators + , UndecidableInstances +#-} + +module Main (main) where + +import Control.Monad.Trans +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (unpack) +import Data.Function (on) +import Data.Functor.Contravariant (contramap) +import Data.Int (Int16) +import Data.Scientific (fromFloatDigits) +import Data.Fixed (Fixed(MkFixed), Micro, Pico) +import Data.String (IsString(fromString)) +import Data.Time +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 +import Data.List (sort) + +main :: IO () +main = withUtf8 $ do + withConnection connectionString $ define createDB + Main.defaultMain [checkSequential roundtrips] + withConnection connectionString $ define dropDB + +roundtrips :: Group +roundtrips = Group "roundtrips" + [ roundtrip int2 genInt16 + , roundtrip int4 genInt32 + , roundtrip int8 genInt64 + , roundtrip bool Gen.bool + , roundtrip numeric genScientific + , roundtrip float4 genFloat + , roundtrip float8 genDouble + , roundtripOn normalizeAscii text genStringAscii + , roundtripOn normalizeUtf8 text genStringUnicode + -- , roundtripOn normalizeUtf8 text genStringAll + , roundtripOn normalizeTimeOfDay time genTimeOfDay + -- , roundtrip timetz genTimeWithZone + , roundtripOn normalizeLocalTime timestamp genLocalTime + , roundtrip timestamptz genUTCTime + , roundtrip date genDay + , roundtrip interval genDiffTime + , roundtripOn normalizeIntRange int4range (genRange genInt32) + , roundtripOn normalizeIntRange int8range (genRange genInt64) + , roundtrip numrange (genRange genScientific) + , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime) + , roundtrip tstzrange (genRange genUTCTime) + , roundtripOn normalizeIntRange daterange (genRange genDay) + , roundtrip (typedef #schwarma) genSchwarma + , roundtrip (vararray (typedef #schwarma)) genSchwarmaArray + , roundtrip (typerow #tab) genRow + , roundtrip (vararray (typetable #tab)) genRowArray + , ("table insert", roundtripTable) + ] + where + genInt16 = Gen.int16 Range.exponentialBounded + genInt32 = Gen.int32 Range.exponentialBounded + genInt64 = Gen.int64 Range.exponentialBounded + genScientific = fromFloatDigits <$> genFloat + genPosFloat = Gen.float + (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat) + genFloat = Gen.prune $ Gen.choice + [ genPosFloat + , negate <$> genPosFloat + , Gen.element [0,1/0,-1/0] + ] + genPosDouble = Gen.double + (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat) + genDouble = Gen.prune $ Gen.choice + [ genPosDouble + , negate <$> genPosDouble + , Gen.element [0,1/0,-1/0] + ] + genStringAscii = Gen.string (Range.linear 0 100) Gen.ascii + -- genStringLatin1 = Gen.string (Range.linear 0 100) Gen.latin1 + genStringUnicode = Gen.string (Range.linear 0 100) Gen.unicode + -- genStringAll = Gen.string (Range.linear 0 100) Gen.unicodeAll + genRange gen = do + lb <- gen + ub <- Gen.filter (lb <) gen + Gen.element + [ Empty, singleton lb, whole + , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub + , atLeast lb, moreThan lb, atMost ub, lessThan ub ] + genDay = do + y <- toInteger <$> Gen.int (Range.constant 2000 2019) + m <- Gen.int (Range.constant 1 12) + d <- Gen.int (Range.constant 1 28) + return $ fromGregorian y m d + genDiffTime = do + secs <- secondsToDiffTime . toInteger <$> + Gen.int (Range.constant 0 86401) + picos <- picosecondsToDiffTime . (* 1000000) . toInteger <$> + Gen.int (Range.constant 0 (1000000 - 1)) + return $ secs + picos + genUTCTime = UTCTime <$> genDay <*> genDiffTime + genTimeOfDay = do + h <- Gen.int (Range.constant 0 23) + m <- Gen.int (Range.constant 0 59) + s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59) + return $ TimeOfDay h m s + genLocalTime = LocalTime <$> genDay <*> genTimeOfDay + -- 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 + genRow = HaskRow + <$> genInt16 + <*> Gen.enumBounded + <*> Gen.bool + genRowArray = VarArray <$> Gen.list (Range.constant 1 10) genRow + +roundtrip + :: forall x + . ( ToPG DB x, FromPG x, Inline x + , OidOf DB (PG x), PGTyped DB (PG x) + , Show x, Eq x, NullPG x ~ 'NotNull (PG x) ) + => TypeExpression DB ('NotNull (PG x)) + -> Gen x + -> (PropertyName, Property) +roundtrip = roundtripOn id + +roundtripOn + :: forall x + . ( ToPG DB x, FromPG x, Inline x + , OidOf DB (PG x), PGTyped DB (PG x) + , Show x, Eq x, NullPG x ~ 'NotNull (PG x) ) + => (x -> x) + -> TypeExpression DB ('NotNull (PG x)) + -> Gen x + -> (PropertyName, Property) +roundtripOn norm ty gen = propertyWithName $ do + x <- forAll gen + Just (Only y) <- lift . withConnection connectionString $ + firstRow =<< runQueryParams + (values_ (parameter @1 ty `as` #fromOnly)) (Only x) + Just (Only z) <- lift . withConnection connectionString $ + firstRow =<< runQuery + (values_ (inline @x @'NotNull x `as` #fromOnly)) + y === z + norm x === y + where + propertyWithName prop = + (fromString (unpack (renderSQL ty)), property prop) + +maxPosFloat :: RealFloat a => a +maxPosFloat = x + where + n = floatDigits x + b = floatRadix x + (_, u) = floatRange x + x = encodeFloat (b^n - 1) (u - n) + +minPosFloat :: RealFloat a => a +minPosFloat = x + where + n = floatDigits x + b = floatRadix x + (l, _) = floatRange x + x = encodeFloat (b^n - 1) (l - n - 1) + +connectionString :: ByteString +connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" + +normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int +normalizeIntRange = \case + Empty -> Empty + NonEmpty l u -> + let + l' = normalizeL l + u' = normalizeU u + in if emptyNormalized l' u' then Empty else NonEmpty l' u' + where + normalizeL = \case + Open l -> Closed (succ l) + normalized -> normalized + normalizeU = \case + Closed u -> Open (succ u) + normalized -> normalized + emptyNormalized (Closed l) (Open u) = l >= u + emptyNormalized _ _ = False + +normalizeTimeOfDay :: TimeOfDay -> TimeOfDay +normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m + . fromRational @Pico + . toRational @Micro + . fromRational @Micro + . toRational @Pico + $ s + +normalizeLocalTime :: LocalTime -> LocalTime +normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t) + +-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone) +-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z) + +normalizeAscii :: String -> String +normalizeAscii = (stripped =<<) + where + stripped = \case + '\NUL' -> "" + ch -> [ch] + +normalizeUtf8 :: String -> String +normalizeUtf8 = (stripped =<<) + where + stripped = \case + '\NUL' -> "" + ch -> [ch] + +data Schwarma = Chicken | Lamb | Beef + deriving stock (Eq, Ord, Show, Bounded, Enum, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (IsPG, FromPG, ToPG db, Inline) via Enumerated Schwarma + +data HaskRow = HaskRow {foo :: Int16, bar :: Schwarma, baz :: Bool} + deriving stock (Eq, Ord, Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (IsPG, FromPG, Inline) via Composite HaskRow +deriving via Composite HaskRow + instance db ~ DB => ToPG db HaskRow + +type Schema = '[ + "schwarma" ::: 'Typedef (PG Schwarma), + "tab" ::: 'Table ('[] :=> PGRow)] + +type DB = Public Schema + +type DB0 = Public '[] + +createDB :: Definition DB0 DB +createDB = + createTypeEnumFrom @Schwarma #schwarma >>> + createTable #tab + ( notNullable int2 `as` #foo :* + notNullable (typedef #schwarma) `as` #bar :* + notNullable bool `as` #baz + ) Nil + +dropDB :: Definition DB DB0 +dropDB = dropTable #tab >>> dropType #schwarma + +type PGRow = '[ + "foo" ::: 'NoDef :=> 'NotNull 'PGint2, + "bar" ::: 'NoDef :=> 'NotNull (PG Schwarma), + "baz" ::: 'NoDef :=> 'NotNull 'PGbool] + +insertTabInline :: [HaskRow] -> Statement DB () () +insertTabInline = \case + [] -> error "needs at least 1 row" + rw:rows -> manipulation $ insertInto_ #tab (inlineValues rw rows) + +insertTabParams :: Statement DB HaskRow () +insertTabParams = manipulation . insertInto_ #tab . Values_ $ + Set (param @1) `as` #foo :* + Set (param @2) `as` #bar :* + Set (param @3) `as` #baz + +insertTabUnnest :: Statement DB [HaskRow] () +insertTabUnnest = Manipulation enc dec sql + where + enc = contramap VarArray aParam + dec = return () + sql = insertInto_ #tab unnested + unnested = Select fields (from (unnest (param @1))) + fields = + Set (#unnest & field #tab #foo) `as` #foo :* + Set (#unnest & field #tab #bar) `as` #bar :* + Set (#unnest & field #tab #baz) `as` #baz + +selectTab :: Statement DB () HaskRow +selectTab = query $ select Star (from (table #tab)) + +roundtripTable :: Property +roundtripTable = property $ do + let + genInt16 = Gen.int16 Range.exponentialBounded + genRow = HaskRow + <$> genInt16 + <*> Gen.enumBounded + <*> Gen.bool + genRows = Gen.list (Range.constant 1 100) genRow + rows1 <- forAll genRows + rows2 <- forAll genRows + rows3 <- forAll genRows + tabRows <- lift . withConnection connectionString $ ephemerally_ $ do + execute_ (insertTabInline rows1) + executePrepared_ insertTabParams rows2 + executeParams_ insertTabUnnest rows3 + getRows =<< execute selectTab + ((===) `on` sort) tabRows (rows1 ++ rows2 ++ rows3) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE + DataKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , DuplicateRecordFields + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedLabels + , OverloadedStrings + , RankNTypes + , StandaloneDeriving + , TypeApplications + , TypeFamilies + , TypeSynonymInstances + , DataKinds + , PolyKinds + , TypeOperators + , UndecidableInstances +#-} + +module Main (main) where + +import Control.Concurrent.Async (replicateConcurrently) +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Text (Text) +import Test.Hspec + +import qualified Data.ByteString.Char8 as Char8 (unlines) +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC + +import Squeal.PostgreSQL + +main :: IO () +main = hspec spec + +type UsersConstraints = + '[ "pk_users" ::: 'PrimaryKey '["id"] + , "unique_names" ::: 'Unique '["name"] ] + +type UsersColumns = + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] + +type Schema = + '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) + , "person" ::: 'Typedef (PG Person) ] + +type DB = '[ "public" ::: Schema ] + +data User = User + { userName :: Text + } deriving stock (Eq, Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +insertUser :: Manipulation_ DB User () +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 + ( serial `as` #id :* + notNullable text `as` #name ) + ( primaryKey #id `as` #pk_users :* + unique #name `as` #unique_names ) >>> + createTypeCompositeFrom @Person #person + +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 = execute_ silent + +setupDB :: IO () +setupDB = withConnection connectionString $ + silence & pqThen (define setup) + +dropDB :: IO () +dropDB = withConnection connectionString $ + silence & pqThen (define teardown) + +connectionString :: ByteString +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) + deriving (IsPG, FromPG, ToPG db, Inline) via (Composite Person) + +spec :: Spec +spec = before_ setupDB . after_ dropDB $ do + + describe "Exceptions" $ do + + let + testUser = User "TestUser" + newUser :: User -> Transaction DB () + newUser usr = manipulateParams_ insertUser usr + insertUserTwice :: Transaction DB () + insertUserTwice = newUser testUser >> newUser testUser + err23505 = UniqueViolation $ Char8.unlines + [ "ERROR: duplicate key value violates unique constraint \"unique_names\"" + , "DETAIL: Key (name)=(TestUser) already exists." ] + + it "should be thrown for constraint violation" $ + withConnection connectionString insertUserTwice + `shouldThrow` (== err23505) + + it "should be rethrown for constraint violation in a transaction" $ + withConnection connectionString (transactionally_ insertUserTwice) + `shouldThrow` (== err23505) + + describe "Pools" $ + + it "should manage concurrent transactions" $ do + pool <- createConnectionPool + "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) + session = usingConnectionPool pool $ transactionally_ $ + firstRow =<< runQuery qry + chrs <- replicateConcurrently 10 session + chrs `shouldSatisfy` all (== Just (Only 'a')) + + describe "Ranges" $ + + it "should correctly decode ranges" $ do + + rangesOut <- withConnection connectionString $ do + let + qry :: Query_ (Public '[]) () (Only (Range Int32)) + qry = values + ( range int4range (atLeast 3) `as` #fromOnly ) + [ range int4range (3 <=..< 5) `as` #fromOnly + , range int4range Empty `as` #fromOnly + , range int4range whole `as` #fromOnly ] + getRows =<< runQuery qry + (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe` + [ atLeast 3, 3 <=..< 5, Empty, whole ] + + describe "Parameters" $ do + + it "should run queries that don't reference all their parameters" $ do + + out <- withConnection connectionString $ do + let + qry :: Query_ (Public '[]) (Char,Int32) (Only Int32) + qry = values_ (param @2 `as` #fromOnly) + firstRow =<< runQueryParams qry ('a', 3 :: Int32) + (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3 + + describe "Composite types" $ do + + it "should be embeddible" $ do + + let + + roundtrip :: Query_ DB (Only Person) (Only Person) + roundtrip = values_ (param @1 `as` #fromOnly) + + roundtrip_inline :: Person -> Query_ DB () (Only Person) + roundtrip_inline person = values_ (inline person `as` #fromOnly) + + roundtrip_array :: Query_ DB + (Only (VarArray [Person])) (Only (VarArray [Person])) + roundtrip_array = values_ (param @1 `as` #fromOnly) + + oneway :: Query_ DB () (Only Person) + oneway = values_ (row ("Adam" `as` #name :* 6000 `as` #age) `as` #fromOnly) + + oneway_array :: Query_ DB () (Only (VarArray [Person])) + oneway_array = values_ $ array + [ row ("Adam" `as` #name :* 6000 `as` #age) + , row ("Lucy" `as` #name :* 2420000 `as` #age) + ] `as` #fromOnly + + unsafeQ :: Query_ DB () (Only (VarArray [Composite Person])) + unsafeQ = UnsafeQuery "select array[row(\'Adam\', 6000)]" + + nothingQ :: Query_ DB () (Only Person) + nothingQ = values_ (row (null_ `as` #name :* null_ `as` #age) `as` #fromOnly) + + adam = Person (Just "Adam") (Just 6000) + lucy = Person (Just "Lucy") (Just 2420000) + people = VarArray [adam, lucy] + + out <- withConnection connectionString $ + firstRow =<< runQueryParams roundtrip (Only adam) + out_inline <- withConnection connectionString $ + firstRow =<< runQuery (roundtrip_inline adam) + out_array <- withConnection connectionString $ + firstRow =<< runQueryParams roundtrip_array (Only people) + out2 <- withConnection connectionString $ + firstRow =<< runQuery oneway + out2_array <- withConnection connectionString $ + firstRow =<< runQuery oneway_array + unsafe_array <- withConnection connectionString $ + firstRow =<< runQuery unsafeQ + nothings <- withConnection connectionString $ + firstRow =<< runQuery nothingQ + + out `shouldBe` Just (Only adam) + out_inline `shouldBe` Just (Only adam) + out_array `shouldBe` Just (Only people) + out2 `shouldBe` Just (Only adam) + 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 diff --git a/test/Specs/ExceptionHandling.hs b/test/Specs/ExceptionHandling.hs deleted file mode 100644 --- a/test/Specs/ExceptionHandling.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -module ExceptionHandling - ( specs - , User (..) - ) where - -import Control.Concurrent.Async (replicateConcurrently) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Int (Int16) -import Data.Text (Text) -import Data.Vector (Vector) -import Test.Hspec - -import qualified Data.ByteString.Char8 as Char8 -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL - -type Schema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] - , "unique_names" ::: 'Unique '["name"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2)) - ]) - , "emails" ::: 'Table ( - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) - ] - -type Schemas = Public Schema - -data User = - User { userName :: Text - , userEmail :: Maybe Text - , userVec :: VarArray (Vector (Maybe Int16)) } - deriving (Show, GHC.Generic) -instance SOP.Generic User -instance SOP.HasDatatypeInfo User - -insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))] - '[ "fromOnly" ::: 'NotNull 'PGint4 ] -insertUser = insertInto #users - (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) - OnConflictDoRaise (Returning (#id `as` #fromOnly)) - -setup :: Definition (Public '[]) Schemas -setup = - createTable #users - ( serial `as` #id :* - (text & notNullable) `as` #name :* - (vararray int2 & notNullable) `as` #vec ) - ( primaryKey #id `as` #pk_users - :* unique #name `as` #unique_names ) - >>> - createTable #emails - ( serial `as` #id :* - (int & notNullable) `as` #user_id :* - (text & nullable) `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) - -teardown :: Definition Schemas (Public '[]) -teardown = dropTable #emails >>> dropTable #users - -migration :: Migration Definition (Public '[]) Schemas -migration = Migration { name = "test" - , up = setup - , down = teardown } - -setupDB :: IO () -setupDB = withConnection connectionString $ - manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;") - & pqThen (migrateUp (single migration)) - -dropDB :: IO () -dropDB = withConnection connectionString $ - manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;") - & pqThen (migrateDown (single migration)) - -connectionString :: Char8.ByteString -connectionString = "host=localhost port=5432 dbname=exampledb" - -testUser :: User -testUser = User "TestUser" Nothing (VarArray []) - -newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m () -newUser u = void $ manipulateParams insertUser (userName u, userVec u) - -insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m () -insertUserTwice = newUser testUser >> newUser testUser - -specs :: SpecWith () -specs = before_ setupDB $ after_ dropDB $ - describe "Exceptions" $ do - - let - dupKeyErr = PQException $ PQState FatalError (Just "23505") - (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n") - - it "should be thrown for unique constraint violation in a manipulation" $ - withConnection connectionString insertUserTwice - `shouldThrow` (== dupKeyErr) - - it "should be rethrown for unique constraint violation in a manipulation by a transaction" $ - withConnection connectionString (transactionally_ insertUserTwice) - `shouldThrow` (== dupKeyErr) - - it "should handle concurrent transactions using pooled connections" $ do - pool <- createConnectionPool - "host=localhost port=5432 dbname=exampledb" 1 0.5 10 - let - query :: Query_ (Public '[]) () (Only Char) - query = values_ (literal 'a' `as` #fromOnly) - session = usingConnectionPool pool . transactionally_ $ do - result <- runQuery query - Just (Only chr) <- firstRow result - return chr - chrs <- replicateConcurrently 10 session - chrs `shouldSatisfy` (all (== 'a')) diff --git a/test/Specs/Specs.hs b/test/Specs/Specs.hs deleted file mode 100644 --- a/test/Specs/Specs.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Test.Hspec -import qualified ExceptionHandling - -main :: IO () -main = hspec ExceptionHandling.specs