diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Scrive AB + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Scrive nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal new file mode 100644 --- /dev/null +++ b/hpqtypes-extras.cabal @@ -0,0 +1,73 @@ +name: hpqtypes-extras +version: 1.2.4 +synopsis: Extra utilities for hpqtypes library +description: The following extras for hpqtypes library: + . + * DSL for easy, modular construction of SQL queries. + . + * System for automatic validation and migration of a database schema. +homepage: https://github.com/scrive/hpqtypes-extras +license: BSD3 +license-file: LICENSE +author: Scrive +maintainer: Andrzej Rybczak , + Jonathan Jouty +category: Database +build-type: Simple +cabal-version: >=1.10 + +Source-repository head + Type: git + Location: git@github.com:scrive/hpqtypes-extras.git + +library + hs-source-dirs: src + + ghc-options: -Wall + + exposed-modules: Database.PostgreSQL.PQTypes.Checks + , Database.PostgreSQL.PQTypes.Model + , Database.PostgreSQL.PQTypes.Model.Check + , Database.PostgreSQL.PQTypes.Model.ColumnType + , Database.PostgreSQL.PQTypes.Model.CompositeType + , Database.PostgreSQL.PQTypes.Model.Domain + , Database.PostgreSQL.PQTypes.Model.Extension + , Database.PostgreSQL.PQTypes.Model.ForeignKey + , Database.PostgreSQL.PQTypes.Model.Index + , Database.PostgreSQL.PQTypes.Model.Migration + , Database.PostgreSQL.PQTypes.Model.PrimaryKey + , Database.PostgreSQL.PQTypes.Model.Table + , Database.PostgreSQL.PQTypes.SQL.Builder + , Database.PostgreSQL.PQTypes.Versions + + build-depends: base < 5 + , base16-bytestring + , bytestring + , containers + , cryptohash + , exceptions + , fields-json + , hpqtypes >= 1.5.0 + , lifted-base + , log > 0.5.2 + , monad-control >= 1.0.0.0 + , mtl + , text + , text-show + + default-language: Haskell2010 + default-extensions: BangPatterns + , DeriveDataTypeable + , ExistentialQuantification + , FlexibleContexts + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiWayIf + , OverloadedStrings + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeFamilies + , UndecidableInstances diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -0,0 +1,561 @@ +module Database.PostgreSQL.PQTypes.Checks ( + migrateDatabase + , checkDatabase + , createTable + , createDomain + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.Catch +import Control.Monad.Reader +import Data.Int +import Data.Maybe +import Data.Monoid +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes hiding (def) +import Log +import Prelude +import TextShow +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Text as T + +import Database.PostgreSQL.PQTypes.Model +import Database.PostgreSQL.PQTypes.SQL.Builder +import Database.PostgreSQL.PQTypes.Versions + +newtype ValidationResult = ValidationResult [T.Text] -- ^ list of error messages + +instance Monoid ValidationResult where + mempty = ValidationResult [] + mappend (ValidationResult a) (ValidationResult b) = ValidationResult (a ++ b) + +topMessage :: T.Text -> T.Text -> ValidationResult -> ValidationResult +topMessage objtype objname = \case + ValidationResult [] -> ValidationResult [] + ValidationResult es -> ValidationResult ("There are problems with the" <+> objtype <+> "'" <> objname <> "'" : es) + +resultCheck + :: (MonadLog m, MonadThrow m) + => ValidationResult + -> m () +resultCheck = \case + ValidationResult [] -> return () + ValidationResult msgs -> do + mapM_ logAttention_ msgs + error "resultCheck: validation failed" + +---------------------------------------- + +-- | Runs all checks on a database +migrateDatabase + :: (MonadDB m, MonadLog m, MonadThrow m) + => [Extension] -> [Domain] -> [Table] -> [Migration m] + -> m () +migrateDatabase extensions domains tables migrations = do + void checkDBTimeZone + mapM_ checkExtension extensions + checkDBConsistency domains (tableVersions : tables) migrations + resultCheck =<< checkDomainsStructure domains + resultCheck =<< checkDBStructure (tableVersions : tables) + checkUnknownTables tables + + -- everything is OK, commit changes + commit + +checkDatabase + :: (MonadDB m, MonadLog m, MonadThrow m) + => [Domain] -> [Table] + -> m () +checkDatabase domains tables = do + versions <- mapM checkTableVersion tables + let tablesWithVersions = zip tables (map (fromMaybe 0) versions) + resultCheck . mconcat $ checkVersions tablesWithVersions + resultCheck =<< checkDomainsStructure domains + resultCheck =<< checkDBStructure (tableVersions : tables) + -- check initial setups only after database structure is considered + -- consistent as before that some of the checks may fail internally. + resultCheck . mconcat =<< checkInitialSetups tables + where + checkVersions = map $ \(t@Table{..}, v) -> ValidationResult $ if + | tblVersion == v -> [] + | v == 0 -> ["Table '" <> tblNameText t <> "' must be created"] + | otherwise -> ["Table '" <> tblNameText t <> "' must be migrated" <+> showt v <+> "->" <+> showt tblVersion] + + checkInitialSetups = mapM $ \t -> case tblInitialSetup t of + Nothing -> return $ ValidationResult [] + Just is -> checkInitialSetup is >>= \case + True -> return $ ValidationResult [] + False -> return $ ValidationResult ["Initial setup for table '" <> tblNameText t <> "' is not valid"] + +-- | Return SQL fragment of current catalog within quotes +currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ()) +currentCatalog = do + runSQL_ "SELECT current_catalog::text" + dbname <- fetchOne runIdentity + return $ unsafeSQL $ "\"" ++ dbname ++ "\"" + +-- | Check for a given extension. We need to read from 'pg_extension' +-- table as Amazon RDS limits usage of 'CREATE EXTENSION IF NOT EXISTS'. +checkExtension :: (MonadDB m, MonadLog m, MonadThrow m) => Extension -> m () +checkExtension (Extension extension) = do + logInfo_ $ "Checking for extension '" <> txtExtension <> "'" + extensionExists <- runQuery01 . sqlSelect "pg_extension" $ do + sqlResult "TRUE" + sqlWhereEq "extname" $ unRawSQL extension + if not extensionExists + then do + logInfo_ $ "Creating extension '" <> txtExtension <> "'" + runSQL_ $ "CREATE EXTENSION IF NOT EXISTS" <+> raw extension + else logInfo_ $ "Extension '" <> txtExtension <> "' exists" + where + txtExtension = unRawSQL extension + +-- | Checks whether database returns timestamps in UTC +checkDBTimeZone :: (MonadDB m, MonadLog m, MonadThrow m) => m Bool +checkDBTimeZone = do + runSQL_ "SHOW timezone" + timezone :: String <- fetchOne runIdentity + if timezone /= "UTC" + then do + dbname <- currentCatalog + logInfo_ $ "Setting '" <> unRawSQL dbname <> "' database to return timestamps in UTC" + runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'" + return True + else return False + +checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m () +checkUnknownTables tables = do + runQuery_ $ sqlSelect "information_schema.tables" $ do + sqlResult "table_name::text" + sqlWhere "table_name <> 'table_versions'" + sqlWhere "table_type = 'BASE TABLE'" + sqlWhere "table_schema NOT IN ('information_schema','pg_catalog')" + desc <- fetchMany runIdentity + let absent = desc L.\\ map (unRawSQL . tblName) tables + when (not (null absent)) $ + mapM_ (\t -> logInfo_ $ "Unknown table:" <+> t) absent + +createTable :: MonadDB m => Bool -> Table -> m () +createTable withConstraints table@Table{..} = do + -- Create empty table and add the columns. + runQuery_ $ sqlCreateTable tblName + runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns + -- Add indexes. + forM_ tblIndexes $ runQuery_ . sqlCreateIndex tblName + -- Add all the other constraints if applicable. + when withConstraints $ createTableConstraints table + -- Register the table along with its version. + runQuery_ . sqlInsert "table_versions" $ do + sqlSet "name" (tblNameText table) + sqlSet "version" tblVersion + +createTableConstraints :: MonadDB m => Table -> m () +createTableConstraints Table{..} = when (not $ null addConstraints) $ do + runQuery_ $ sqlAlterTable tblName addConstraints + where + addConstraints = concat [ + [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey] + , map sqlAddCheck tblChecks + , map (sqlAddFK tblName) tblForeignKeys + ] + +checkDomainsStructure :: (MonadDB m, MonadThrow m) + => [Domain] -> m ValidationResult +checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do + runQuery_ . sqlSelect "pg_catalog.pg_type t1" $ do + sqlResult "t1.typname::text" -- name + sqlResult "(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) FROM pg_catalog.pg_type t2 WHERE t2.oid = t1.typbasetype)" -- type + sqlResult "NOT t1.typnotnull" -- nullable + sqlResult "t1.typdefault" -- default value + sqlResult "ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint names + sqlResult "ARRAY(SELECT regexp_replace(pg_get_constraintdef(c.oid, true), 'CHECK \\((.*)\\)', '\\1') FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint definitions + sqlWhereEq "t1.typname" $ unRawSQL $ domName def + mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds) -> Domain { + domName = unsafeSQL dname + , domType = dtype + , domNullable = nullable + , domDefault = unsafeSQL <$> defval + , domChecks = mkChecks $ zipWith (\cname cond -> Check { + chkName = unsafeSQL cname + , chkCondition = unsafeSQL cond + }) (unArray1 cnames) (unArray1 conds) + } + return $ case mdom of + Just dom + | dom /= def -> topMessage "domain" (unRawSQL $ domName dom) $ mconcat [ + compareAttr dom def "name" domName + , compareAttr dom def "type" domType + , compareAttr dom def "nullable" domNullable + , compareAttr dom def "default" domDefault + , compareAttr dom def "checks" domChecks + ] + | otherwise -> mempty + Nothing -> ValidationResult ["Domain '" <> unRawSQL (domName def) <> "' doesn't exist in the database"] + where + compareAttr :: (Eq a, Show a) => Domain -> Domain -> T.Text -> (Domain -> a) -> ValidationResult + compareAttr dom def attrname attr + | attr dom == attr def = ValidationResult [] + | otherwise = ValidationResult ["Attribute '" <> attrname <> "' does not match (database:" <+> T.pack (show $ attr dom) <> ", definition:" <+> T.pack (show $ attr def) <> ")"] + +createDomain :: MonadDB m => Domain -> m () +createDomain dom@Domain{..} = do + -- create the domain + runQuery_ $ sqlCreateDomain dom + -- add constraint checks to the domain + F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddCheck + +-- | Checks whether database is consistent (performs migrations if necessary) +checkDBStructure :: forall m. (MonadDB m, MonadThrow m) + => [Table] -> m ValidationResult +checkDBStructure tables = fmap mconcat . forM tables $ \table -> + -- final checks for table structure, we do this + -- both when creating stuff and when migrating + topMessage "table" (tblNameText table) <$> checkTableStructure table + where + checkTableStructure :: Table -> m ValidationResult + checkTableStructure table@Table{..} = do + -- get table description from pg_catalog as describeTable + -- mechanism from HDBC doesn't give accurate results + runQuery_ $ sqlSelect "pg_catalog.pg_attribute a" $ do + sqlResult "a.attname::text" + sqlResult "pg_catalog.format_type(a.atttypid, a.atttypmod)" + sqlResult "NOT a.attnotnull" + sqlResult . parenthesize . toSQLCommand $ + sqlSelect "pg_catalog.pg_attrdef d" $ do + sqlResult "pg_catalog.pg_get_expr(d.adbin, d.adrelid)" + sqlWhere "d.adrelid = a.attrelid" + sqlWhere "d.adnum = a.attnum" + sqlWhere "a.atthasdef" + sqlWhere "a.attnum > 0" + sqlWhere "NOT a.attisdropped" + sqlWhereEqSql "a.attrelid" $ sqlGetTableID table + sqlOrderBy "a.attnum" + desc <- fetchMany fetchTableColumn + -- get info about constraints from pg_catalog + runQuery_ $ sqlGetPrimaryKey table + pk <- join <$> fetchMaybe fetchPrimaryKey + runQuery_ $ sqlGetChecks table + checks <- fetchMany fetchTableCheck + runQuery_ $ sqlGetIndexes table + indexes <- fetchMany fetchTableIndex + runQuery_ $ sqlGetForeignKeys table + fkeys <- fetchMany fetchForeignKey + return $ mconcat [ + checkColumns 1 tblColumns desc + , checkPrimaryKey tblPrimaryKey pk + , checkChecks tblChecks checks + , checkIndexes tblIndexes indexes + , checkForeignKeys tblForeignKeys fkeys + ] + where + fetchTableColumn :: (String, ColumnType, Bool, Maybe String) -> TableColumn + fetchTableColumn (name, ctype, nullable, mdefault) = TableColumn { + colName = unsafeSQL name + , colType = ctype + , colNullable = nullable + , colDefault = unsafeSQL `liftM` mdefault + } + + checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult + checkColumns _ [] [] = mempty + checkColumns _ rest [] = ValidationResult [tableHasLess "columns" rest] + checkColumns _ [] rest = ValidationResult [tableHasMore "columns" rest] + checkColumns !n (d:defs) (c:cols) = mconcat [ + validateNames $ colName d == colName c + -- bigserial == bigint + autoincrement and there is no + -- distinction between them after table is created. + , validateTypes $ colType d == colType c || (colType d == BigSerialT && colType c == BigIntT) + -- there is a problem with default values determined by sequences as + -- they're implicitely specified by db, so let's omit them in such case + , validateDefaults $ colDefault d == colDefault c || (colDefault d == Nothing && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c) == Just True) + , validateNullables $ colNullable d == colNullable c + , checkColumns (n+1) defs cols + ] + where + validateNames True = mempty + validateNames False = ValidationResult [errorMsg ("no. " <> showt n) "names" (unRawSQL . colName)] + + validateTypes True = mempty + validateTypes False = ValidationResult [errorMsg cname "types" (T.pack . show . colType) <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d))] + + validateNullables True = mempty + validateNullables False = ValidationResult [errorMsg cname "nullables" (showt . colNullable) <+> sqlHint ((if colNullable d then "DROP" else "SET") <+> "NOT NULL")] + + validateDefaults True = mempty + validateDefaults False = ValidationResult [(errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)) <+> sqlHint set_default] + where + set_default = case colDefault d of + Just v -> "SET DEFAULT" <+> v + Nothing -> "DROP DEFAULT" + + cname = unRawSQL $ colName d + errorMsg ident attr f = "Column '" <> ident <> "' differs in" <+> attr <+> "(table:" <+> f c <> ", definition:" <+> f d <> ")." + sqlHint sql = "(HINT: SQL for making the change is: ALTER TABLE" <+> tblNameText table <+> "ALTER COLUMN" <+> unRawSQL (colName d) <+> unRawSQL sql <> ")" + + checkPrimaryKey :: Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult + checkPrimaryKey mdef mpk = mconcat [ + checkEquality "PRIMARY KEY" def (map fst pk) + , checkNames (const (pkName tblName)) pk + ] + where + def = maybeToList mdef + pk = maybeToList mpk + + checkChecks :: [Check] -> [Check] -> ValidationResult + checkChecks defs checks = case checkEquality "CHECKs" defs checks of + ValidationResult [] -> ValidationResult [] + ValidationResult errmsgs -> ValidationResult $ errmsgs ++ [" (HINT: If checks are equal modulo number of parentheses/whitespaces used in conditions, just copy and paste expected output into source code)"] + + checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult + checkIndexes defs indexes = mconcat [ + checkEquality "INDEXes" defs (map fst indexes) + , checkNames (indexName tblName) indexes + ] + + checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult + checkForeignKeys defs fkeys = mconcat [ + checkEquality "FOREIGN KEYs" defs (map fst fkeys) + , checkNames (fkName tblName) fkeys + ] + +-- | Checks whether database is consistent (performs migrations if necessary) +checkDBConsistency + :: forall m. (MonadDB m, MonadLog m, MonadThrow m) + => [Domain] -> [Table] -> [Migration m] + -> m () +checkDBConsistency domains tables migrations = do + -- check if migrations list has the following properties: + -- - consecutive mgrFrom numbers + -- - no duplicates + -- - all mgrFrom are less than table version number of the table in the database (or the just created table) + forM_ tables $ \table -> do + let presentMigrationVersions = map mgrFrom $ filter (\m -> tblName (mgrTable m) == tblName table) migrations + expectedMigrationVersions = reverse $ take (length presentMigrationVersions) $ reverse [0 .. tblVersion table - 1] + when (presentMigrationVersions /= expectedMigrationVersions) $ do + logAttention "Migrations are invalid" $ object [ + "table" .= tblNameText table + , "migration_versions" .= presentMigrationVersions + , "expected_migration_versions" .= expectedMigrationVersions + ] + error $ "checkDBConsistency: invalid migrations for table" <+> tblNameString table + + versions <- mapM checkTableVersion tables + let tablesWithVersions = zip tables (map (fromMaybe 0) versions) + + if all ((==) 0 . snd) tablesWithVersions + then do + -- No tables are present, create everything from scratch. + logInfo_ "Creating domains..." + mapM_ createDomain domains + logInfo_ "Creating tables..." + -- Create all tables with no constraints first to allow cyclic references. + mapM_ (createTable False) tables + logInfo_ "Creating table constraints..." + mapM_ createTableConstraints tables + logInfo_ "Done." + logInfo_ "Running initial setup for tables..." + forM_ tables $ \t -> case tblInitialSetup t of + Nothing -> return () + Just tis -> do + logInfo_ $ "Intializing" <+> tblNameText t <> "..." + initialSetup tis + logInfo_ "Done." + + else do + -- Migration mode. + forM_ tablesWithVersions $ \(table, ver) -> when (tblVersion table /= ver) $ do + case L.find (\m -> tblNameString (mgrTable m) == tblNameString table) migrations of + Nothing -> do + error $ "checkDBConsistency: no migrations found for table '" ++ tblNameString table ++ "', cannot migrate " ++ show ver ++ " -> " ++ show (tblVersion table) + Just m | mgrFrom m > ver -> do + error $ "checkDBConsistency: earliest migration for table '" ++ tblNameString table ++ "' is from version " ++ show (mgrFrom m) ++ ", cannot migrate " ++ show ver ++ " -> " ++ show (tblVersion table) + Just _ -> return () + + let migrationsToRun = filter (\m -> any (\(t, from) -> tblName (mgrTable m) == tblName t && mgrFrom m >= from) tablesWithVersions) migrations + + -- Run migrations, if necessary. + when (not . null $ migrationsToRun) $ do + logInfo_ "Running migrations..." + forM_ migrationsToRun $ \migration -> do + logInfo_ $ arrListTable (mgrTable migration) <> showt (mgrFrom migration) <+> "->" <+> showt (succ $ mgrFrom migration) + mgrDo migration + runQuery_ $ sqlUpdate "table_versions" $ do + sqlSet "version" $ succ (mgrFrom migration) + sqlWhereEq "name" $ tblNameString (mgrTable migration) + logInfo_ "Running migrations... done." + +checkTableVersion :: (MonadDB m, MonadThrow m) => Table -> m (Maybe Int32) +checkTableVersion table = do + doesExist <- runQuery01 . sqlSelect "pg_catalog.pg_class c" $ do + sqlResult "TRUE" + sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace" + sqlWhereEq "c.relname" $ tblNameString table + sqlWhere "pg_catalog.pg_table_is_visible(c.oid)" + if doesExist + then do + runQuery_ $ "SELECT version FROM table_versions WHERE name =" tblNameString table + mver <- fetchMaybe runIdentity + case mver of + Just ver -> return $ Just ver + Nothing -> error $ "checkTableVersion: table '" ++ tblNameString table ++ "' is present in the database, but there is no corresponding version info in 'table_versions'." + else do + return Nothing + +-- *** TABLE STRUCTURE *** + +sqlGetTableID :: Table -> SQL +sqlGetTableID table = parenthesize . toSQLCommand $ + sqlSelect "pg_catalog.pg_class c" $ do + sqlResult "c.oid" + sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace" + sqlWhereEq "c.relname" $ tblNameString table + sqlWhere "pg_catalog.pg_table_is_visible(c.oid)" + +-- *** PRIMARY KEY *** + +sqlGetPrimaryKey :: Table -> SQL +sqlGetPrimaryKey table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do + sqlResult "c.conname::text" + sqlResult "array(SELECT a.attname::text FROM pg_catalog.pg_attribute a WHERE a.attrelid = c.conrelid AND a.attnum = ANY (c.conkey)) as columns" -- list of affected columns + sqlWhereEq "c.contype" 'p' + sqlWhereEqSql "c.conrelid" $ sqlGetTableID table + +fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()) +fetchPrimaryKey (name, Array1 columns) = (, unsafeSQL name) + <$> (pkOnColumns $ map unsafeSQL columns) + +-- *** CHECKS *** + +sqlGetChecks :: Table -> SQL +sqlGetChecks table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do + sqlResult "c.conname::text" + sqlResult "regexp_replace(pg_get_constraintdef(c.oid, true), 'CHECK \\((.*)\\)', '\\1') AS body" -- check body + sqlWhereEq "c.contype" 'c' + sqlWhereEqSql "c.conrelid" $ sqlGetTableID table + +fetchTableCheck :: (String, String) -> Check +fetchTableCheck (name, condition) = Check { + chkName = unsafeSQL name +, chkCondition = unsafeSQL condition +} + +-- *** INDEXES *** + +sqlGetIndexes :: Table -> SQL +sqlGetIndexes table = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do + sqlResult "c.relname::text" -- index name + sqlResult $ "ARRAY(" <> selectCoordinates <> ")" -- array of index coordinates + sqlResult "i.indisunique" -- is it unique? + sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)" -- if partial, get constraint def + sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid" + sqlLeftJoinOn "pg_catalog.pg_constraint r" "r.conrelid = i.indrelid AND r.conindid = i.indexrelid" + sqlWhereEqSql "i.indrelid" $ sqlGetTableID table + sqlWhereIsNULL "r.contype" -- fetch only "pure" indexes + where + -- Get all coordinates of the index. + selectCoordinates = smconcat [ + "WITH RECURSIVE coordinates(k, name) AS (" + , " VALUES (0, NULL)" + , " UNION ALL" + , " SELECT k+1, pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true)" + , " FROM coordinates" + , " WHERE pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true) != ''" + , ")" + , "SELECT name FROM coordinates WHERE k > 0" + ] + +fetchTableIndex :: (String, Array1 String, Bool, Maybe String) -> (TableIndex, RawSQL ()) +fetchTableIndex (name, Array1 columns, unique, mconstraint) = (TableIndex { + idxColumns = map unsafeSQL columns +, idxUnique = unique +, idxWhere = unsafeSQL `liftM` mconstraint +}, unsafeSQL name) + +-- *** FOREIGN KEYS *** + +sqlGetForeignKeys :: Table -> SQL +sqlGetForeignKeys table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint r" $ do + sqlResult "r.conname::text" -- fk name + sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN (" <> unnestWithOrdinality "r.conkey" <> ") conkeys ON (a.attnum = conkeys.item) WHERE a.attrelid = r.conrelid ORDER BY conkeys.n)" -- constrained columns + sqlResult "c.relname::text" -- referenced table + sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN (" <> unnestWithOrdinality "r.confkey" <> ") confkeys ON (a.attnum = confkeys.item) WHERE a.attrelid = r.confrelid ORDER BY confkeys.n)" -- referenced columns + sqlResult "r.confupdtype" -- on update + sqlResult "r.confdeltype" -- on delete + sqlResult "r.condeferrable" -- deferrable? + sqlResult "r.condeferred" -- initially deferred? + sqlJoinOn "pg_catalog.pg_class c" "c.oid = r.confrelid" + sqlWhereEqSql "r.conrelid" $ sqlGetTableID table + sqlWhereEq "r.contype" 'f' + where + unnestWithOrdinality :: RawSQL () -> SQL + unnestWithOrdinality arr = "SELECT n, " <> raw arr <> "[n] AS item FROM generate_subscripts(" <> raw arr <> ", 1) AS n" + +fetchForeignKey :: (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool) -> (ForeignKey, RawSQL ()) +fetchForeignKey (name, Array1 columns, reftable, Array1 refcolumns, on_update, on_delete, deferrable, deferred) = (ForeignKey { + fkColumns = map unsafeSQL columns +, fkRefTable = unsafeSQL reftable +, fkRefColumns = map unsafeSQL refcolumns +, fkOnUpdate = charToForeignKeyAction on_update +, fkOnDelete = charToForeignKeyAction on_delete +, fkDeferrable = deferrable +, fkDeferred = deferred +}, unsafeSQL name) + where + charToForeignKeyAction c = case c of + 'a' -> ForeignKeyNoAction + 'r' -> ForeignKeyRestrict + 'c' -> ForeignKeyCascade + 'n' -> ForeignKeySetNull + 'd' -> ForeignKeySetDefault + _ -> error $ "fetchForeignKey: invalid foreign key action code: " ++ show c + +-- *** UTILS *** + +tblNameText :: Table -> T.Text +tblNameText = unRawSQL . tblName + +tblNameString :: Table -> String +tblNameString = T.unpack . tblNameText + +checkEquality :: (Eq t, Show t) => T.Text -> [t] -> [t] -> ValidationResult +checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of + ([], []) -> mempty + (def_diff, db_diff) -> ValidationResult [mconcat [ + "Table and its definition have diverged and have " + , showt $ length db_diff + , " and " + , showt $ length def_diff + , " different " + , pname + , " each, respectively (table: " + , T.pack $ show db_diff + , ", definition: " + , T.pack $ show def_diff + , ")." + ]] + +checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult +checkNames prop_name = mconcat . map check + where + check (prop, name) = case prop_name prop of + pname + | pname == name -> mempty + | otherwise -> ValidationResult [mconcat [ + "Property " + , T.pack $ show prop + , " has invalid name (expected: " + , unRawSQL pname + , ", given: " + , unRawSQL name + , ")." + ]] + +tableHasLess :: Show t => T.Text -> t -> T.Text +tableHasLess ptype missing = "Table in the database has *less*" <+> ptype <+> "than its definition (missing:" <+> T.pack (show missing) <> ")" + +tableHasMore :: Show t => T.Text -> t -> T.Text +tableHasMore ptype extra = "Table in the database has *more*" <+> ptype <+> "than its definition (extra:" <+> T.pack (show extra) <> ")" + +arrListTable :: Table -> T.Text +arrListTable table = " ->" <+> tblNameText table <> ": " diff --git a/src/Database/PostgreSQL/PQTypes/Model.hs b/src/Database/PostgreSQL/PQTypes/Model.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model.hs @@ -0,0 +1,24 @@ +module Database.PostgreSQL.PQTypes.Model ( + module Database.PostgreSQL.PQTypes.Model.Check + , module Database.PostgreSQL.PQTypes.Model.ColumnType + , module Database.PostgreSQL.PQTypes.Model.CompositeType + , module Database.PostgreSQL.PQTypes.Model.Domain + , module Database.PostgreSQL.PQTypes.Model.Extension + , module Database.PostgreSQL.PQTypes.Model.ForeignKey + , module Database.PostgreSQL.PQTypes.Model.Index + , module Database.PostgreSQL.PQTypes.Model.Migration + , module Database.PostgreSQL.PQTypes.Model.PrimaryKey + , module Database.PostgreSQL.PQTypes.Model.Table + ) where + +import Database.PostgreSQL.PQTypes.Model.Check +import Database.PostgreSQL.PQTypes.Model.ColumnType +import Database.PostgreSQL.PQTypes.Model.CompositeType +import Database.PostgreSQL.PQTypes.Model.Domain +import Database.PostgreSQL.PQTypes.Model.Extension +import Database.PostgreSQL.PQTypes.Model.ForeignKey +import Database.PostgreSQL.PQTypes.Model.Index +import Database.PostgreSQL.PQTypes.Model.Migration +import Database.PostgreSQL.PQTypes.Model.PrimaryKey +import Database.PostgreSQL.PQTypes.Model.Table + diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -0,0 +1,26 @@ +module Database.PostgreSQL.PQTypes.Model.Check ( + Check(..) + , sqlAddCheck + , sqlDropCheck + ) where + +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes +import Prelude + +data Check = Check { + chkName :: RawSQL () +, chkCondition :: RawSQL () +} deriving (Eq, Ord, Show) + +sqlAddCheck :: Check -> RawSQL () +sqlAddCheck Check{..} = smconcat [ + "ADD CONSTRAINT" + , chkName + , "CHECK (" + , chkCondition + , ")" + ] + +sqlDropCheck :: Check -> RawSQL () +sqlDropCheck Check{..} = "DROP CONSTRAINT" <+> chkName diff --git a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs @@ -0,0 +1,72 @@ +module Database.PostgreSQL.PQTypes.Model.ColumnType ( + ColumnType(..) + , columnTypeToSQL + ) where + +import Control.Applicative ((<$>)) +import Data.Monoid +import Database.PostgreSQL.PQTypes +import Prelude +import qualified Data.Text as T + +data ColumnType + = BigIntT + | BigSerialT + | BinaryT + | BoolT + | DateT + | DoubleT + | IntegerT + | IntervalT + | JsonT + | JsonbT + | SmallIntT + | TextT + | TimestampWithZoneT + | XmlT + | ArrayT !ColumnType + | CustomT !(RawSQL ()) + deriving (Eq, Ord, Show) + +instance PQFormat ColumnType where + pqFormat = const $ pqFormat (undefined::T.Text) +instance FromSQL ColumnType where + type PQBase ColumnType = PQBase T.Text + fromSQL mbase = parseType . T.toLower <$> fromSQL mbase + where + parseType :: T.Text -> ColumnType + parseType = \case + "bigint" -> BigIntT + "bytea" -> BinaryT + "boolean" -> BoolT + "date" -> DateT + "double precision" -> DoubleT + "integer" -> IntegerT + "interval" -> IntervalT + "json" -> JsonT + "jsonb" -> JsonbT + "smallint" -> SmallIntT + "text" -> TextT + "timestamp with time zone" -> TimestampWithZoneT + "xml" -> XmlT + tname + | "[]" `T.isSuffixOf` tname -> ArrayT . parseType $ T.take (T.length tname - 2) tname + | otherwise -> CustomT $ rawSQL tname () + +columnTypeToSQL :: ColumnType -> RawSQL () +columnTypeToSQL BigIntT = "BIGINT" +columnTypeToSQL BigSerialT = "BIGSERIAL" +columnTypeToSQL BinaryT = "BYTEA" +columnTypeToSQL BoolT = "BOOLEAN" +columnTypeToSQL DateT = "DATE" +columnTypeToSQL DoubleT = "DOUBLE PRECISION" +columnTypeToSQL IntegerT = "INTEGER" +columnTypeToSQL IntervalT = "INTERVAL" +columnTypeToSQL JsonT = "JSON" +columnTypeToSQL JsonbT = "JSONB" +columnTypeToSQL SmallIntT = "SMALLINT" +columnTypeToSQL TextT = "TEXT" +columnTypeToSQL TimestampWithZoneT = "TIMESTAMPTZ" +columnTypeToSQL XmlT = "XML" +columnTypeToSQL (ArrayT t) = columnTypeToSQL t <> "[]" +columnTypeToSQL (CustomT tname) = tname diff --git a/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs b/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs @@ -0,0 +1,43 @@ +module Database.PostgreSQL.PQTypes.Model.CompositeType ( + CompositeType(..) + , CompositeColumn(..) + , defineComposites + ) where + +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes +import Prelude + +import Database.PostgreSQL.PQTypes.Model.ColumnType + +data CompositeType = CompositeType { + ctName :: !(RawSQL ()) +, ctColumns :: ![CompositeColumn] +} deriving (Eq, Ord, Show) + +data CompositeColumn = CompositeColumn { + ccName :: !(RawSQL ()) +, ccType :: ColumnType +} deriving (Eq, Ord, Show) + +-- | Composite types are static in a sense that they can either +-- be created or dropped, altering them is not possible. Therefore +-- they are not part of the migration process. This is not a problem +-- since their exclusive usage is for intermediate representation +-- of complex nested data structures fetched from the database. +defineComposites :: MonadDB m => [CompositeType] -> m () +defineComposites ctypes = do + mapM_ (runQuery_ . sqlDropComposite) $ reverse ctypes + mapM_ (runQuery_ . sqlCreateComposite) $ ctypes + where + sqlCreateComposite CompositeType{..} = smconcat [ + "CREATE TYPE" + , ctName + , "AS (" + , mintercalate ", " $ map columnToSQL ctColumns + , ")" + ] + where + columnToSQL CompositeColumn{..} = ccName <+> columnTypeToSQL ccType + + sqlDropComposite = ("DROP TYPE IF EXISTS" <+>) . ctName diff --git a/src/Database/PostgreSQL/PQTypes/Model/Domain.hs b/src/Database/PostgreSQL/PQTypes/Model/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Domain.hs @@ -0,0 +1,82 @@ +module Database.PostgreSQL.PQTypes.Model.Domain ( + Domain(..) + , mkChecks + , sqlCreateDomain + , sqlAlterDomain + , sqlDropDomain + ) where + +import Data.Monoid.Utils +import Data.Set (Set, fromList) +import Database.PostgreSQL.PQTypes +import Prelude + +import Database.PostgreSQL.PQTypes.Model.Check +import Database.PostgreSQL.PQTypes.Model.ColumnType + +-- Domains are global, i.e. not bound to any particular table. +-- The first table that uses a new domain needs to create it +-- by a migration. +-- +-- If a migration that alters the domain needs to be performed, +-- there are three possible situations: +-- +-- 1) The modification doesn't require data change in any of the tables. +-- 2) The modification requires data change, but only in one table. +-- 3) The modification requires data change in more than one table. +-- +-- These situations should be handled as follows: +-- +-- 1) One of the tables that use the domain should migrate it. +-- 2) The table that requires data modification should migrate it. +-- 3) One of the tables that require data modification should migrate it. +-- Note that modification of constraints may conflict with the data in +-- the other tables. In this case, these constraints should be created +-- as NOT VALID (see http://www.postgresql.org/docs/current/static/sql-alterdomain.html +-- for more info) and VALIDATEd in the migration of the last table with +-- the conflicting data. +-- +-- TODO: the proper solution to this is to version the domains to be +-- able to handle (1) and the first and last part of (3) by migrating +-- the domain itself, however that requires substantial change to the +-- migration system. +-- +-- As opposed to the current solution, the other temporary one is to +-- create domains statically and not worry about migrations. The problem +-- with this approach is the separation of domain creation from the rest +-- of the universe, which results in problems later, when the proper +-- solution will have to be implemented (i.e. one would need to go back +-- and edit old migrations), whereas the current solution makes the +-- transition trivial. + +data Domain = Domain { + -- | Name of the domain. + domName :: RawSQL () + -- | Type of the domain. +, domType :: ColumnType + -- | Defines whether the domain value can be NULL. + -- *Cannot* be superseded by a table column definition. +, domNullable :: Bool + -- Default value for the domain. *Can* be + -- superseded by a table column definition. +, domDefault :: Maybe (RawSQL ()) + -- Set of constraint checks on the domain. +, domChecks :: Set Check +} deriving (Eq, Ord, Show) + +mkChecks :: [Check] -> Set Check +mkChecks = fromList + +sqlCreateDomain :: Domain -> RawSQL () +sqlCreateDomain Domain{..} = smconcat [ + "CREATE DOMAIN" <+> domName <+> "AS" + , columnTypeToSQL domType + , if domNullable then "NULL" else "NOT NULL" + , maybe "" ("DEFAULT" <+>) domDefault + ] + +sqlAlterDomain :: RawSQL () -> RawSQL () -> RawSQL () +sqlAlterDomain dname alter = "ALTER DOMAIN" <+> dname <+> alter + +sqlDropDomain :: RawSQL () -> RawSQL () +sqlDropDomain dname = "DROP DOMAIN" <+> dname diff --git a/src/Database/PostgreSQL/PQTypes/Model/Extension.hs b/src/Database/PostgreSQL/PQTypes/Model/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Extension.hs @@ -0,0 +1,15 @@ +module Database.PostgreSQL.PQTypes.Model.Extension ( + Extension(..) + , ununExtension + ) where + +import Data.String +import Data.Text (Text) +import Database.PostgreSQL.PQTypes +import Prelude + +newtype Extension = Extension { unExtension :: RawSQL () } + deriving (Eq, Ord, Show, IsString) + +ununExtension :: Extension -> Text +ununExtension = unRawSQL . unExtension diff --git a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs @@ -0,0 +1,82 @@ +module Database.PostgreSQL.PQTypes.Model.ForeignKey ( + ForeignKey(..) + , ForeignKeyAction(..) + , fkOnColumn + , fkOnColumns + , fkName + , sqlAddFK + , sqlDropFK + ) where + +import Data.Monoid +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes +import Prelude +import qualified Data.Text as T + +data ForeignKey = ForeignKey { + fkColumns :: [RawSQL ()] +, fkRefTable :: RawSQL () +, fkRefColumns :: [RawSQL ()] +, fkOnUpdate :: ForeignKeyAction +, fkOnDelete :: ForeignKeyAction +, fkDeferrable :: Bool +, fkDeferred :: Bool +} deriving (Eq, Ord, Show) + +data ForeignKeyAction + = ForeignKeyNoAction + | ForeignKeyRestrict + | ForeignKeyCascade + | ForeignKeySetNull + | ForeignKeySetDefault + deriving (Eq, Ord, Show) + +fkOnColumn :: RawSQL () -> RawSQL () -> RawSQL () -> ForeignKey +fkOnColumn column reftable refcolumn = + fkOnColumns [column] reftable [refcolumn] + +fkOnColumns :: [RawSQL ()] -> RawSQL () -> [RawSQL ()] -> ForeignKey +fkOnColumns columns reftable refcolumns = ForeignKey { + fkColumns = columns +, fkRefTable = reftable +, fkRefColumns = refcolumns +, fkOnUpdate = ForeignKeyCascade +, fkOnDelete = ForeignKeyNoAction +, fkDeferrable = True +, fkDeferred = False +} + +fkName :: RawSQL () -> ForeignKey -> RawSQL () +fkName tname ForeignKey{..} = shorten $ mconcat [ + "fk__" + , tname + , "__" + , mintercalate "__" fkColumns + , "__" + , fkRefTable + ] + where + -- PostgreSQL's limit for identifier is 63 characters + shorten = flip rawSQL () . T.take 63 . unRawSQL + +sqlAddFK :: RawSQL () -> ForeignKey -> RawSQL () +sqlAddFK tname fk@ForeignKey{..} = mconcat [ + "ADD CONSTRAINT" <+> fkName tname fk <+> "FOREIGN KEY (" + , mintercalate ", " fkColumns + , ") REFERENCES" <+> fkRefTable <+> "(" + , mintercalate ", " fkRefColumns + , ") ON UPDATE" <+> foreignKeyActionToSQL fkOnUpdate + , " ON DELETE" <+> foreignKeyActionToSQL fkOnDelete + , " " <> if fkDeferrable then "DEFERRABLE" else "NOT DEFERRABLE" + , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE" + ] + where + foreignKeyActionToSQL ForeignKeyNoAction = "NO ACTION" + foreignKeyActionToSQL ForeignKeyRestrict = "RESTRICT" + foreignKeyActionToSQL ForeignKeyCascade = "CASCADE" + foreignKeyActionToSQL ForeignKeySetNull = "SET NULL" + foreignKeyActionToSQL ForeignKeySetDefault = "SET DEFAULT" + +sqlDropFK :: RawSQL () -> ForeignKey -> RawSQL () +sqlDropFK tname fk = "DROP CONSTRAINT" <+> fkName tname fk diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -0,0 +1,99 @@ +module Database.PostgreSQL.PQTypes.Model.Index ( + TableIndex(..) + , tblIndex + , indexOnColumn + , indexOnColumns + , uniqueIndexOnColumn + , uniqueIndexOnColumnWithCondition + , uniqueIndexOnColumns + , indexName + , sqlCreateIndex + , sqlDropIndex + ) where + +import Crypto.Hash.RIPEMD160 +import Data.ByteString.Base16 +import Data.Char +import Data.Monoid +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes +import Prelude +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data TableIndex = TableIndex { + idxColumns :: [RawSQL ()] +, idxUnique :: Bool +, idxWhere :: Maybe (RawSQL ()) +} deriving (Eq, Ord, Show) + +tblIndex :: TableIndex +tblIndex = TableIndex { + idxColumns = [] +, idxUnique = False +, idxWhere = Nothing +} + +indexOnColumn :: RawSQL () -> TableIndex +indexOnColumn column = tblIndex { idxColumns = [column] } + +indexOnColumns :: [RawSQL ()] -> TableIndex +indexOnColumns columns = tblIndex { idxColumns = columns } + +uniqueIndexOnColumn :: RawSQL () -> TableIndex +uniqueIndexOnColumn column = TableIndex { + idxColumns = [column] +, idxUnique = True +, idxWhere = Nothing +} + +uniqueIndexOnColumns :: [RawSQL ()] -> TableIndex +uniqueIndexOnColumns columns = TableIndex { + idxColumns = columns +, idxUnique = True +, idxWhere = Nothing +} + +uniqueIndexOnColumnWithCondition :: RawSQL () -> RawSQL () -> TableIndex +uniqueIndexOnColumnWithCondition column whereC = TableIndex { + idxColumns = [column] +, idxUnique = True +, idxWhere = Just whereC +} + +indexName :: RawSQL () -> TableIndex -> RawSQL () +indexName tname TableIndex{..} = flip rawSQL () $ T.take 63 . unRawSQL $ mconcat [ + if idxUnique then "unique_idx__" else "idx__" + , tname + , "__" + , mintercalate "__" $ map (asText sanitize) idxColumns + , maybe "" (("__" <>) . hashWhere) idxWhere + ] + where + asText f = flip rawSQL () . f . unRawSQL + -- See http://www.postgresql.org/docs/9.4/static/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS. + -- Remove all unallowed characters and replace them by at most one adjacent dollar sign. + sanitize = T.pack . foldr go [] . T.unpack + where + go c acc = if isAlphaNum c || c == '_' + then c : acc + else case acc of + ('$':_) -> acc + _ -> '$' : acc + -- hash WHERE clause and add it to index name so that indexes + -- with the same columns, but different constraints can coexist + hashWhere = asText $ T.decodeUtf8 . encode . BS.take 10 . hash . T.encodeUtf8 + +sqlCreateIndex :: RawSQL () -> TableIndex -> RawSQL () +sqlCreateIndex tname idx@TableIndex{..} = mconcat [ + "CREATE " + , if idxUnique then "UNIQUE " else "" + , "INDEX" <+> indexName tname idx <+> "ON" <+> tname <+> "(" + , mintercalate ", " idxColumns + , ")" + , maybe "" (" WHERE" <+>) idxWhere + ] + +sqlDropIndex :: RawSQL () -> TableIndex -> RawSQL () +sqlDropIndex tname idx = "DROP INDEX" <+> indexName tname idx diff --git a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs @@ -0,0 +1,21 @@ +module Database.PostgreSQL.PQTypes.Model.Migration ( + Migration(..) + ) where + +import Data.Int + +import Database.PostgreSQL.PQTypes.Model.Table + +-- | Migration object. Fields description: +-- * mgrTable is the table you're migrating +-- * mgrFrom is the version you're migrating from (you don't specify what +-- version you migrate TO, because version is always increased by 1, so +-- if mgrFrom is 2, that means that after that migration is run, table +-- version will equal 3 +-- * mgrDo is actual body of a migration + +data Migration m = Migration { + mgrTable :: Table +, mgrFrom :: Int32 +, mgrDo :: m () +} diff --git a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs @@ -0,0 +1,39 @@ +module Database.PostgreSQL.PQTypes.Model.PrimaryKey ( + PrimaryKey + , pkOnColumn + , pkOnColumns + , pkName + , sqlAddPK + , sqlDropPK + ) where + +import Data.Monoid (mconcat) +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes +import Prelude +import qualified Data.Set as S + +newtype PrimaryKey = PrimaryKey (S.Set (RawSQL ())) + deriving (Eq, Ord, Show) + +pkOnColumn :: RawSQL () -> Maybe PrimaryKey +pkOnColumn = Just . PrimaryKey . S.singleton + +pkOnColumns :: [RawSQL ()] -> Maybe PrimaryKey +pkOnColumns [] = Nothing +pkOnColumns columns = Just . PrimaryKey . S.fromList $ columns + +pkName :: RawSQL () -> RawSQL () +pkName tname = mconcat ["pk__", tname] + +sqlAddPK :: RawSQL () -> PrimaryKey -> RawSQL () +sqlAddPK tname (PrimaryKey columns) = smconcat [ + "ADD CONSTRAINT" + , pkName tname + , "PRIMARY KEY (" + , mintercalate ", " $ S.toAscList columns + , ")" + ] + +sqlDropPK :: RawSQL () -> RawSQL () +sqlDropPK tname = "DROP CONSTRAINT" <+> pkName tname diff --git a/src/Database/PostgreSQL/PQTypes/Model/Table.hs b/src/Database/PostgreSQL/PQTypes/Model/Table.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Table.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Database.PostgreSQL.PQTypes.Model.Table ( + TableColumn(..) + , tblColumn + , sqlAddColumn + , sqlAlterColumn + , sqlDropColumn + , Rows(..) + , Table(..) + , tblTable + , sqlCreateTable + , sqlAlterTable + , TableInitialSetup(..) + ) where + +import Control.Monad.Catch +import Data.ByteString (ByteString) +import Data.Int +import Data.Monoid.Utils +import Database.PostgreSQL.PQTypes +import Prelude + +import Database.PostgreSQL.PQTypes.Model.Check +import Database.PostgreSQL.PQTypes.Model.ColumnType +import Database.PostgreSQL.PQTypes.Model.ForeignKey +import Database.PostgreSQL.PQTypes.Model.Index +import Database.PostgreSQL.PQTypes.Model.PrimaryKey + +data TableColumn = TableColumn { + colName :: RawSQL () +, colType :: ColumnType +, colNullable :: Bool +, colDefault :: Maybe (RawSQL ()) +} deriving Show + +tblColumn :: TableColumn +tblColumn = TableColumn { + colName = error "tblColumn: column name must be specified" +, colType = error "tblColumn: column type must be specified" +, colNullable = True +, colDefault = Nothing +} + +sqlAddColumn :: TableColumn -> RawSQL () +sqlAddColumn TableColumn{..} = smconcat [ + "ADD COLUMN" + , colName + , columnTypeToSQL colType + , if colNullable then "NULL" else "NOT NULL" + , maybe "" ("DEFAULT" <+>) colDefault + ] + +sqlAlterColumn :: RawSQL () -> RawSQL () -> RawSQL () +sqlAlterColumn cname alter = "ALTER COLUMN" <+> cname <+> alter + +sqlDropColumn :: RawSQL () -> RawSQL () +sqlDropColumn cname = "DROP COLUMN" <+> cname + +---------------------------------------- + +data Rows = forall row. (Show row, ToRow row) => Rows [ByteString] [row] + +data Table = Table { + tblName :: RawSQL () +, tblVersion :: Int32 +, tblColumns :: [TableColumn] +, tblPrimaryKey :: Maybe PrimaryKey +, tblChecks :: [Check] +, tblForeignKeys :: [ForeignKey] +, tblIndexes :: [TableIndex] +, tblInitialSetup :: Maybe TableInitialSetup +} + +data TableInitialSetup = TableInitialSetup { + checkInitialSetup :: forall m. (MonadDB m, MonadThrow m) => m Bool +, initialSetup :: forall m. (MonadDB m, MonadThrow m) => m () +} + +tblTable :: Table +tblTable = Table { + tblName = error "tblTable: table name must be specified" +, tblVersion = error "tblTable: table version must be specified" +, tblColumns = error "tblTable: table columns must be specified" +, tblPrimaryKey = Nothing +, tblChecks = [] +, tblForeignKeys = [] +, tblIndexes = [] +, tblInitialSetup = Nothing +} + +sqlCreateTable :: RawSQL () -> RawSQL () +sqlCreateTable tname = "CREATE TABLE" <+> tname <+> "()" + +sqlAlterTable :: RawSQL () -> [RawSQL ()] -> RawSQL () +sqlAlterTable tname alter_statements = smconcat [ + "ALTER TABLE" + , tname + , mintercalate ", " alter_statements + ] diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs @@ -0,0 +1,1202 @@ +{- | + +Module SQL2 offers some nice monadic function that build SQL commands +on the fly. Some examples: + +> kRun_ $ sqlSelect "documents" $ do +> sqlResult "id" +> sqlResult "title" +> sqlResult "mtime" +> sqlOrderBy "documents.mtime DESC" +> sqlWhereILike "documents.title" pattern + +SQL2 supports SELECT as 'sqlSelect' and data manipulation using +'sqlInsert', 'sqlInsertSelect', 'sqlDelete' and 'sqlUpdate'. + +> kRun_ $ sqlInsert "documents" $ do +> sqlSet "title" title +> sqlSet "ctime" now +> sqlResult "id" + +The 'sqlInsertSelect' is particulary interesting as it supports INSERT +of values taken from a SELECT clause from same or even different +tables. + +There is a possibility to do multiple inserts at once. Data given by +'sqlSetList' will be inserted multiple times, data given by 'sqlSet' +will be multiplied as many times as needed to cover all inserted rows +(it is common to all rows). If you use multiple 'sqlSetList' then +lists will be made equal in length by appending @DEFAULT@ as fill +element. + +> kRun_ $ sqlInsert "documents" $ do +> sqlSet "ctime" now +> sqlSetList "title" [title1, title2, title3] +> sqlResult "id" + +The above will insert 3 new documents. + +SQL2 provides quite a lot of SQL magic, including @ORDER BY@ as +'sqlOrderBy', @GROUP BY@ as 'sqlGroupBy'. + +> kRun_ $ sqlSelect "documents" $ do +> sqlResult "id" +> sqlResult "title" +> sqlResult "mtime" +> sqlOrderBy "documents.mtime DESC" +> sqlOrderBy "documents.title" +> sqlGroupBy "documents.status" +> sqlJoinOn "users" "documents.user_id = users.id" +> sqlWhere $ SQL "documents.title ILIKE ?" [toSql pattern] + +Joins are done by 'sqlJoinOn', 'sqlLeftJoinOn', 'sqlRightJoinOn', +'sqlJoinOn', 'sqlFullJoinOn'. If everything fails use 'sqlJoin' and +'sqlFrom' to set join clause as string. Support for a join grammars as +some kind of abstract syntax data type is lacking. + +> kRun_ $ sqlDelete "mails" $ do +> sqlWhere "id > 67" + +> kRun_ $ sqlUpdate "document_tags" $ do +> sqlSet "value" (123 :: Int) +> sqlWhere "name = 'abc'" + +Exception returning and 'kWhyNot' are a subsystem for querying why a +query did not provide expected results. For example: + +> let query = sqlUpdate "documents" $ do +> sqlSet "deleted" True +> sqlWhereEq "documents.id" 12345 +> sqlWhereEqE DocumentDeleteFlagMustBe "documents.deleted" False +> sqlWhereILikeE DocumentTitleMustContain "documents.title" "%important%" +> result <- kRun query + +In result is zero then no document was updated. We would like to know +what happened. In query we have three filtering clauses. One is a +baseline: the one mentioning @documents.id@. Baseline clauses define +what objects are we talking about. Other clauses are correctness +checks and may fail if status of on object is unexpected. Using +'kWhyNot' we can see what is wrong with an object: + +> problems <- kWhyNot query + +Now problems should contain a list of issues with rows that could be +possibly be affected by weren't due to correctness clauses. For +example it may state: + +> problems = [[ DocumentDeleteFlagMustBe { documentDeleteFlagMustBe = False +> , documentDeleteFlagReallyIs = True +> } +> , DocumentTitleMustContain { documentTitleMustContain = "%important%" +> , documentTitleReallyIs = "Some contract v2" +> } +> ]] + +Note: problems is a nested array, for each object we get a list of +issues pertaining to that object. If that list is empty, then it means +that baseline conditions failed or there is no such object that +fullfills all conditions at the same time although there are some that +fullfill each one separatelly. + +-} + +-- TODO: clean this up and fix the mess with +-- "randomly" wrapping stuff in parentheses. + +module Database.PostgreSQL.PQTypes.SQL.Builder + ( sqlWhere + , sqlWhereE + , sqlWhereEV + , sqlWhereEVV + , sqlWhereEVVV + , sqlWhereEVVVV + , sqlWhereEq + , sqlWhereEqE + , sqlWhereEqSql + , sqlWhereNotEq + , sqlWhereNotEqE + , sqlWhereIn + , sqlWhereInSql + , sqlWhereInE + , sqlWhereNotIn + , sqlWhereNotInSql + , sqlWhereNotInE + , sqlWhereExists + , sqlWhereNotExists + , sqlWhereLike + , sqlWhereLikeE + , sqlWhereILike + , sqlWhereILikeE + , sqlWhereIsNULL + , sqlWhereIsNotNULL + , sqlWhereIsNULLE + + , sqlIgnore + + , sqlFrom + , sqlJoin + , sqlJoinOn + , sqlLeftJoinOn + , sqlRightJoinOn + , sqlFullJoinOn + , sqlSet + , sqlSetInc + , sqlSetList + , sqlSetListWithDefaults + , sqlSetCmd + , sqlSetCmdList + , sqlCopyColumn + , sqlResult + , sqlOrderBy + , sqlGroupBy + , sqlHaving + , sqlOffset + , sqlLimit + , sqlDistinct + , sqlWith + + , SqlTurnIntoSelect + , sqlTurnIntoSelect + , sqlTurnIntoWhyNotSelect + + , sqlSelect + , sqlSelect2 + , SqlSelect(..) + , sqlInsert + , SqlInsert(..) + , sqlInsertSelect + , SqlInsertSelect(..) + , sqlUpdate + , SqlUpdate(..) + , sqlDelete + , SqlDelete(..) + + , sqlWhereAny + + , SqlResult + , SqlSet + , SqlFrom + , SqlWhere + , SqlOrderBy + , SqlGroupByHaving + , SqlOffsetLimit + , SqlDistinct + + + , SqlCondition(..) + , sqlGetWhereConditions + + , SqlWhyNot(..) + + , kWhyNot1 + --, DBExceptionCouldNotParseValues(..) + , kRun1OrThrowWhyNot + , kRun1OrThrowWhyNotAllowIgnore + , kRunManyOrThrowWhyNot + , kRunAndFetch1OrThrowWhyNot + + , DBExtraException(..) + , SomeDBExtraException(..) + , catchDBExtraException + , DBBaseLineConditionIsFalse(..) + + , Sqlable(..) + , sqlOR + , sqlConcatComma + , sqlConcatAND + , sqlConcatOR + , parenthesize + , AscDesc(..) + ) + where + +import Control.Exception.Lifted as E +import Control.Monad.Catch +import Control.Monad.State +import Control.Monad.Trans.Control +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Monoid.Utils +import Data.String +import Data.Typeable +import Database.PostgreSQL.PQTypes +import Prelude +import qualified Text.JSON.Gen as JSON + +class Sqlable a where + toSQLCommand :: a -> SQL + +instance Sqlable SQL where + toSQLCommand = id + +smintercalate :: (IsString m, Monoid m) => m -> [m] -> m +smintercalate m = mintercalate $ mconcat [mspace, m, mspace] + +sqlOR :: SQL -> SQL -> SQL +sqlOR s1 s2 = sqlConcatOR [s1, s2] + +sqlConcatComma :: [SQL] -> SQL +sqlConcatComma = mintercalate ", " + +sqlConcatAND :: [SQL] -> SQL +sqlConcatAND = smintercalate "AND" . map parenthesize + +sqlConcatOR :: [SQL] -> SQL +sqlConcatOR = smintercalate "OR" . map parenthesize + +parenthesize :: SQL -> SQL +parenthesize s = "(" <> s <> ")" + +-- | 'AscDesc' marks ORDER BY order as ascending or descending. +-- Conversion to SQL adds DESC marker to descending and no marker +-- to ascending order. +data AscDesc a = Asc a | Desc a + deriving (Eq, Show) + +data Multiplicity a = Single a | Many [a] + deriving (Eq, Ord, Show, Typeable) + +-- | 'SqlCondition' are clauses that are in SQL statements in the +-- WHERE block. Each statement has a list of conditions, all of them +-- must be fullfilled. Sometimes we need to inspect internal +-- structure of a condition. For now it seems that the only +-- interesting case is EXISTS (SELECT ...) because that internal +-- SELECT can have explainable clauses. +data SqlCondition = SqlPlainCondition SQL SqlWhyNot + | SqlExistsCondition SqlSelect + deriving (Typeable, Show) + +-- | 'SqlWhyNot' contains recepie how to query the database for +-- current values in there and construct proper exception object using +-- that information. For @SqlWhyNot mkException queries@ the +-- @mkException@ should take as input same lenth list as there are +-- queries. Each query will be run in a JOIN context with all +-- referenced tables, so it can extract values from there. +data SqlWhyNot = forall e row. (FromRow row, DBExtraException e) => SqlWhyNot Bool (row -> e) [SQL] + +{- +instance Eq SqlCondition where + (SqlPlainCondition a _) == (SqlPlainCondition b _) = a == b + (SqlExistsCondition a) == (SqlExistsCondition b) = a == b + _ == _ = False + -} + +instance Show SqlWhyNot where + show (SqlWhyNot _important exc expr) = "SqlWhyNot " ++ show (typeOf (exc $undefined)) ++ " " ++ show expr + +instance Sqlable SqlCondition where + toSQLCommand (SqlPlainCondition a _) = a + toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a { sqlSelectResult = ["TRUE"] }) <> ")" + +data SqlSelect = SqlSelect + { sqlSelectFrom :: SQL + , sqlSelectDistinct :: Bool + , sqlSelectResult :: [SQL] + , sqlSelectWhere :: [SqlCondition] + , sqlSelectOrderBy :: [SQL] + , sqlSelectGroupBy :: [SQL] + , sqlSelectHaving :: [SQL] + , sqlSelectOffset :: Integer + , sqlSelectLimit :: Integer + , sqlSelectWith :: [(SQL, SQL)] + } + +data SqlUpdate = SqlUpdate + { sqlUpdateWhat :: SQL + , sqlUpdateFrom :: SQL + , sqlUpdateWhere :: [SqlCondition] + , sqlUpdateSet :: [(SQL,SQL)] + , sqlUpdateResult :: [SQL] + , sqlUpdateWith :: [(SQL, SQL)] + } + +data SqlInsert = SqlInsert + { sqlInsertWhat :: SQL + , sqlInsertSet :: [(SQL, Multiplicity SQL)] + , sqlInsertResult :: [SQL] + , sqlInsertWith :: [(SQL, SQL)] + } + +data SqlInsertSelect = SqlInsertSelect + { sqlInsertSelectWhat :: SQL + , sqlInsertSelectDistinct :: Bool + , sqlInsertSelectSet :: [(SQL, SQL)] + , sqlInsertSelectResult :: [SQL] + , sqlInsertSelectFrom :: SQL + , sqlInsertSelectWhere :: [SqlCondition] + , sqlInsertSelectOrderBy :: [SQL] + , sqlInsertSelectGroupBy :: [SQL] + , sqlInsertSelectHaving :: [SQL] + , sqlInsertSelectOffset :: Integer + , sqlInsertSelectLimit :: Integer + , sqlInsertSelectWith :: [(SQL, SQL)] + } + +data SqlDelete = SqlDelete + { sqlDeleteFrom :: SQL + , sqlDeleteUsing :: SQL + , sqlDeleteWhere :: [SqlCondition] + , sqlDeleteResult :: [SQL] + , sqlDeleteWith :: [(SQL, SQL)] + } + +-- | This is not exported and is used as an implementation detail in +-- 'sqlWhereAll'. +data SqlAll = SqlAll + { sqlAllWhere :: [SqlCondition] + } + +instance Show SqlSelect where + show = show . toSQLCommand + +instance Show SqlInsert where + show = show . toSQLCommand + +instance Show SqlInsertSelect where + show = show . toSQLCommand + +instance Show SqlUpdate where + show = show . toSQLCommand + +instance Show SqlDelete where + show = show . toSQLCommand + +instance Show SqlAll where + show = show . toSQLCommand + +emitClause :: Sqlable sql => SQL -> sql -> SQL +emitClause name s = case toSQLCommand s of + sql + | isSqlEmpty sql -> "" + | otherwise -> name <+> sql + +emitClausesSep :: SQL -> SQL -> [SQL] -> SQL +emitClausesSep _name _sep [] = mempty +emitClausesSep name sep sqls = name <+> smintercalate sep (filter (not . isSqlEmpty) $ map parenthesize sqls) + +emitClausesSepComma :: SQL -> [SQL] -> SQL +emitClausesSepComma _name [] = mempty +emitClausesSepComma name sqls = name <+> sqlConcatComma (filter (not . isSqlEmpty) sqls) + +instance IsSQL SqlSelect where + withSQL = withSQL . toSQLCommand + +instance IsSQL SqlInsert where + withSQL = withSQL . toSQLCommand + +instance IsSQL SqlInsertSelect where + withSQL = withSQL . toSQLCommand + +instance IsSQL SqlUpdate where + withSQL = withSQL . toSQLCommand + +instance IsSQL SqlDelete where + withSQL = withSQL . toSQLCommand + +instance Sqlable SqlSelect where + toSQLCommand cmd = + emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlSelectWith cmd)) <+> + "SELECT" <+> (if sqlSelectDistinct cmd then "DISTINCT" else mempty) <+> + sqlConcatComma (sqlSelectResult cmd) <+> + emitClause "FROM" (sqlSelectFrom cmd) <+> + emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlSelectWhere cmd) <+> + emitClausesSepComma "GROUP BY" (sqlSelectGroupBy cmd) <+> + emitClausesSep "HAVING" "AND" (sqlSelectHaving cmd) <+> + emitClausesSepComma "ORDER BY" (sqlSelectOrderBy cmd) <+> + (if sqlSelectOffset cmd > 0 + then unsafeSQL ("OFFSET " ++ show (sqlSelectOffset cmd)) + else "") <+> + (if sqlSelectLimit cmd >= 0 + then unsafeSQL ("LIMIT " ++ show (sqlSelectLimit cmd)) + else "") + +instance Sqlable SqlInsert where + toSQLCommand cmd = + emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlInsertWith cmd)) <+> + "INSERT INTO" <+> sqlInsertWhat cmd <+> + parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd))) <+> + emitClausesSep "VALUES" "," (map sqlConcatComma (transpose (map (makeLongEnough . snd) (sqlInsertSet cmd)))) <+> + emitClausesSepComma "RETURNING" (sqlInsertResult cmd) + where + -- this is the longest list of values + longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd))) + lengthOfEither (Single _) = 1 + lengthOfEither (Many x) = length x + makeLongEnough (Single x) = take longest (repeat x) + makeLongEnough (Many x) = take longest (x ++ repeat "DEFAULT") + +instance Sqlable SqlInsertSelect where + toSQLCommand cmd = + "INSERT INTO" <+> sqlInsertSelectWhat cmd <+> + parenthesize (sqlConcatComma (map fst (sqlInsertSelectSet cmd))) <+> + parenthesize (toSQLCommand (SqlSelect { sqlSelectFrom = sqlInsertSelectFrom cmd + , sqlSelectDistinct = sqlInsertSelectDistinct cmd + , sqlSelectResult = fmap snd $ sqlInsertSelectSet cmd + , sqlSelectWhere = sqlInsertSelectWhere cmd + , sqlSelectOrderBy = sqlInsertSelectOrderBy cmd + , sqlSelectGroupBy = sqlInsertSelectGroupBy cmd + , sqlSelectHaving = sqlInsertSelectHaving cmd + , sqlSelectOffset = sqlInsertSelectOffset cmd + , sqlSelectLimit = sqlInsertSelectLimit cmd + , sqlSelectWith = sqlInsertSelectWith cmd + })) <+> + emitClausesSepComma "RETURNING" (sqlInsertSelectResult cmd) + +instance Sqlable SqlUpdate where + toSQLCommand cmd = + emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlUpdateWith cmd)) <+> + "UPDATE" <+> sqlUpdateWhat cmd <+> "SET" <+> + sqlConcatComma (map (\(name, command) -> name <> "=" <> command) (sqlUpdateSet cmd)) <+> + emitClause "FROM" (sqlUpdateFrom cmd) <+> + emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlUpdateWhere cmd) <+> + emitClausesSepComma "RETURNING" (sqlUpdateResult cmd) + +instance Sqlable SqlDelete where + toSQLCommand cmd = + emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlDeleteWith cmd)) <+> + "DELETE FROM" <+> sqlDeleteFrom cmd <+> + emitClause "USING" (sqlDeleteUsing cmd) <+> + emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlDeleteWhere cmd) <+> + emitClausesSepComma "RETURNING" (sqlDeleteResult cmd) + +instance Sqlable SqlAll where + toSQLCommand cmd | null (sqlAllWhere cmd) = "TRUE" + toSQLCommand cmd = + "(" <+> smintercalate "AND" (map (parenthesize . toSQLCommand) (sqlAllWhere cmd)) <+> ")" + + +sqlSelect :: SQL -> State SqlSelect () -> SqlSelect +sqlSelect table refine = + execState refine (SqlSelect table False [] [] [] [] [] 0 (-1) []) + +sqlSelect2 :: SQL -> State SqlSelect () -> SqlSelect +sqlSelect2 from refine = + execState refine (SqlSelect from False [] [] [] [] [] 0 (-1) []) + +sqlInsert :: SQL -> State SqlInsert () -> SqlInsert +sqlInsert table refine = + execState refine (SqlInsert table mempty [] []) + +sqlInsertSelect :: SQL -> SQL -> State SqlInsertSelect () -> SqlInsertSelect +sqlInsertSelect table from refine = + execState refine (SqlInsertSelect + { sqlInsertSelectWhat = table + , sqlInsertSelectDistinct = False + , sqlInsertSelectSet = [] + , sqlInsertSelectResult = [] + , sqlInsertSelectFrom = from + , sqlInsertSelectWhere = [] + , sqlInsertSelectOrderBy = [] + , sqlInsertSelectGroupBy = [] + , sqlInsertSelectHaving = [] + , sqlInsertSelectOffset = 0 + , sqlInsertSelectLimit = -1 + , sqlInsertSelectWith = [] + }) + +sqlUpdate :: SQL -> State SqlUpdate () -> SqlUpdate +sqlUpdate table refine = + execState refine (SqlUpdate table mempty [] [] [] []) + +sqlDelete :: SQL -> State SqlDelete () -> SqlDelete +sqlDelete table refine = + execState refine (SqlDelete { sqlDeleteFrom = table + , sqlDeleteUsing = mempty + , sqlDeleteWhere = [] + , sqlDeleteResult = [] + , sqlDeleteWith = [] + }) + +class SqlWith a where + sqlWith1 :: a -> SQL -> SQL -> a + + +instance SqlWith SqlSelect where + sqlWith1 cmd name sql = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql)] } + +instance SqlWith SqlInsertSelect where + sqlWith1 cmd name sql = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql)] } + +instance SqlWith SqlUpdate where + sqlWith1 cmd name sql = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql)] } + +instance SqlWith SqlDelete where + sqlWith1 cmd name sql = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql)] } + +sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () +sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql)) + + + +class SqlWhere a where + sqlWhere1 :: a -> SqlCondition -> a + sqlGetWhereConditions :: a -> [SqlCondition] + +instance SqlWhere SqlSelect where + sqlWhere1 cmd cond = cmd { sqlSelectWhere = sqlSelectWhere cmd ++ [cond] } + sqlGetWhereConditions = sqlSelectWhere + +instance SqlWhere SqlInsertSelect where + sqlWhere1 cmd cond = cmd { sqlInsertSelectWhere = sqlInsertSelectWhere cmd ++ [cond] } + sqlGetWhereConditions = sqlInsertSelectWhere + +instance SqlWhere SqlUpdate where + sqlWhere1 cmd cond = cmd { sqlUpdateWhere = sqlUpdateWhere cmd ++ [cond] } + sqlGetWhereConditions = sqlUpdateWhere + +instance SqlWhere SqlDelete where + sqlWhere1 cmd cond = cmd { sqlDeleteWhere = sqlDeleteWhere cmd ++ [cond] } + sqlGetWhereConditions = sqlDeleteWhere + +instance SqlWhere SqlAll where + sqlWhere1 cmd cond = cmd { sqlAllWhere = sqlAllWhere cmd ++ [cond] } + sqlGetWhereConditions = sqlAllWhere + +newtype SqlWhereIgnore a = SqlWhereIgnore { unSqlWhereIgnore :: a } + + +ignoreWhereClause :: SqlCondition -> SqlCondition +ignoreWhereClause (SqlPlainCondition sql (SqlWhyNot _b f s)) = + SqlPlainCondition sql (SqlWhyNot False f s) +ignoreWhereClause (SqlExistsCondition sql) = + SqlExistsCondition (sql { sqlSelectWhere = map ignoreWhereClause (sqlSelectWhere sql)}) + +instance (SqlWhere a) => SqlWhere (SqlWhereIgnore a) where + sqlWhere1 (SqlWhereIgnore cmd) cond = + SqlWhereIgnore (sqlWhere1 cmd (ignoreWhereClause cond)) + sqlGetWhereConditions (SqlWhereIgnore cmd) = sqlGetWhereConditions cmd + + +sqlIgnore :: (MonadState s m) + => State (SqlWhereIgnore s) a + -> m () +sqlIgnore clauses = modify (\cmd -> unSqlWhereIgnore (execState clauses (SqlWhereIgnore cmd))) + +sqlWhere :: (MonadState v m, SqlWhere v) => SQL -> m () +sqlWhere sql = sqlWhereE (DBBaseLineConditionIsFalse sql) sql + +sqlWhereE :: (MonadState v m, SqlWhere v, DBExtraException e) => e -> SQL -> m () +sqlWhereE exc sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 []))) + where + exc2 (_::()) = exc + +sqlWhereEV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a) => (a -> e, SQL) -> SQL -> m () +sqlWhereEV (exc, vsql) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql]))) + where + exc2 (Identity v1) = exc v1 + +sqlWhereEVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b) => (a -> b -> e, SQL, SQL) -> SQL -> m () +sqlWhereEVV (exc, vsql1, vsql2) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2]))) + where + exc2 (v1, v2) = exc v1 v2 + +sqlWhereEVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c) => (a -> b -> c -> e, SQL, SQL, SQL) -> SQL -> m () +sqlWhereEVVV (exc, vsql1, vsql2, vsql3) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3]))) + where + exc2 (v1, v2, v3) = exc v1 v2 v3 + +sqlWhereEVVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c, FromSQL d) => (a -> b -> c -> d -> e, SQL, SQL, SQL, SQL) -> SQL -> m () +sqlWhereEVVVV (exc, vsql1, vsql2, vsql3, vsql4) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3, vsql4]))) + where + exc2 (v1, v2, v3, v4) = exc v1 v2 v3 v4 + +sqlWhereEq :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m () +sqlWhereEq name value = sqlWhere $ name <+> "=" value + +sqlWhereEqE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, FromSQL a, ToSQL a) + => (a -> a -> e) -> SQL -> a -> m () +sqlWhereEqE exc name value = sqlWhereEV (exc value, name) $ name <+> "=" value + +sqlWhereEqSql :: (MonadState v m, SqlWhere v, Sqlable sql) => SQL -> sql -> m () +sqlWhereEqSql name1 name2 = sqlWhere $ name1 <+> "=" <+> toSQLCommand name2 + +sqlWhereNotEq :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m () +sqlWhereNotEq name value = sqlWhere $ name <+> "<>" value + +sqlWhereNotEqE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a) + => (a -> a -> e) -> SQL -> a -> m () +sqlWhereNotEqE exc name value = sqlWhereEV (exc value, name) $ name <+> "<>" value + +sqlWhereLike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m () +sqlWhereLike name value = sqlWhere $ name <+> "LIKE" value + +sqlWhereLikeE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a) + => (a -> a -> e) -> SQL -> a -> m () +sqlWhereLikeE exc name value = sqlWhereEV (exc value, name) $ name <+> "LIKE" value + +sqlWhereILike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m () +sqlWhereILike name value = sqlWhere $ name <+> "ILIKE" value + +sqlWhereILikeE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a) + => (a -> a -> e) -> SQL -> a -> m () +sqlWhereILikeE exc name value = sqlWhereEV (exc value, name) $ name <+> "ILIKE" value + +sqlWhereIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m () +sqlWhereIn _name [] = sqlWhere "FALSE" +sqlWhereIn name [value] = sqlWhereEq name value +sqlWhereIn name values = do + -- Unpack the array to give query optimizer more options. + sqlWhere $ name <+> "IN (SELECT UNNEST(" Array1 values <+> "))" + +sqlWhereInSql :: (MonadState v m, Sqlable a, SqlWhere v) => SQL -> a -> m () +sqlWhereInSql name sql = sqlWhere $ name <+> "IN" <+> parenthesize (toSQLCommand sql) + +sqlWhereInE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a) + => ([a] -> a -> e) -> SQL -> [a] -> m () +sqlWhereInE exc name [] = sqlWhereEV (exc [], name) "FALSE" +sqlWhereInE exc name [value] = sqlWhereEqE (exc . (\x -> [x])) name value +sqlWhereInE exc name values = + sqlWhereEV (exc values, name) $ name <+> "IN (SELECT UNNEST(" Array1 values <+> "))" + +sqlWhereNotIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m () +sqlWhereNotIn _name [] = sqlWhere "TRUE" +sqlWhereNotIn name [value] = sqlWhereNotEq name value +sqlWhereNotIn name values = sqlWhere $ name <+> "NOT IN (SELECT UNNEST(" Array1 values <+> "))" + +sqlWhereNotInSql :: (MonadState v m, Sqlable a, SqlWhere v) => SQL -> a -> m () +sqlWhereNotInSql name sql = sqlWhere $ name <+> "NOT IN" <+> parenthesize (toSQLCommand sql) + +sqlWhereNotInE :: (MonadState v m, SqlWhere v, DBExtraException e, Show a, ToSQL a, FromSQL a) + => ([a] -> a -> e) -> SQL -> [a] -> m () +sqlWhereNotInE exc name [] = sqlWhereEV (exc [], name) "TRUE" +sqlWhereNotInE exc name [value] = sqlWhereNotEqE (exc . (\x -> [x])) name value +sqlWhereNotInE exc name values = + sqlWhereEV (exc values, name) $ name <+> "NOT IN (SELECT UNNEST(" Array1 values <+> "))" + +sqlWhereExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m () +sqlWhereExists sql = do + modify (\cmd -> sqlWhere1 cmd (SqlExistsCondition sql)) + +sqlWhereNotExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m () +sqlWhereNotExists sqlSelectD = do + sqlWhere ("NOT EXISTS (" <+> toSQLCommand (sqlSelectD { sqlSelectResult = ["TRUE"] }) <+> ")") + +sqlWhereIsNULL :: (MonadState v m, SqlWhere v) => SQL -> m () +sqlWhereIsNULL col = sqlWhere $ col <+> "IS NULL" + +sqlWhereIsNotNULL :: (MonadState v m, SqlWhere v) => SQL -> m () +sqlWhereIsNotNULL col = sqlWhere $ col <+> "IS NOT NULL" + +sqlWhereIsNULLE :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a) + => (a -> e) -> SQL -> m () +sqlWhereIsNULLE exc col = sqlWhereEV (exc, col) $ col <+> "IS NULL" + +sqlWhereAny :: (MonadState v m, SqlWhere v) => [State SqlAll ()] -> m () +sqlWhereAny [] = sqlWhere "FALSE" +sqlWhereAny l = sqlWhere $ "(" <+> smintercalate "OR" (map (parenthesize . toSQLCommand . flip execState (SqlAll [])) l) <+> ")" + +class SqlFrom a where + sqlFrom1 :: a -> SQL -> a + +instance SqlFrom SqlSelect where + sqlFrom1 cmd sql = cmd { sqlSelectFrom = sqlSelectFrom cmd <+> sql } + +instance SqlFrom SqlInsertSelect where + sqlFrom1 cmd sql = cmd { sqlInsertSelectFrom = sqlInsertSelectFrom cmd <+> sql } + +instance SqlFrom SqlUpdate where + sqlFrom1 cmd sql = cmd { sqlUpdateFrom = sqlUpdateFrom cmd <+> sql } + +instance SqlFrom SqlDelete where + sqlFrom1 cmd sql = cmd { sqlDeleteUsing = sqlDeleteUsing cmd <+> sql } + +sqlFrom :: (MonadState v m, SqlFrom v) => SQL -> m () +sqlFrom sql = modify (\cmd -> sqlFrom1 cmd sql) + +sqlJoin :: (MonadState v m, SqlFrom v) => SQL -> m () +sqlJoin table = sqlFrom (", " <+> table) + +sqlJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m () +sqlJoinOn table condition = sqlFrom (" JOIN " <+> + table <+> + " ON " <+> + condition) + +sqlLeftJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m () +sqlLeftJoinOn table condition = sqlFrom (" LEFT JOIN " <+> + table <+> + " ON " <+> + condition) + +sqlRightJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m () +sqlRightJoinOn table condition = sqlFrom (" RIGHT JOIN " <+> + table <+> + " ON " <+> + condition) + +sqlFullJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m () +sqlFullJoinOn table condition = sqlFrom (" FULL JOIN " <+> + table <+> + " ON " <+> + condition) + +class SqlSet a where + sqlSet1 :: a -> SQL -> SQL -> a + +instance SqlSet SqlUpdate where + sqlSet1 cmd name v = cmd { sqlUpdateSet = sqlUpdateSet cmd ++ [(name, v)] } + +instance SqlSet SqlInsert where + sqlSet1 cmd name v = cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Single v)] } + +instance SqlSet SqlInsertSelect where + sqlSet1 cmd name v = cmd { sqlInsertSelectSet = sqlInsertSelectSet cmd ++ [(name, v)] } + +sqlSetCmd :: (MonadState v m, SqlSet v) => SQL -> SQL -> m () +sqlSetCmd name sql = modify (\cmd -> sqlSet1 cmd name sql) + +sqlSetCmdList :: (MonadState SqlInsert m) => SQL -> [SQL] -> m () +sqlSetCmdList name as = modify (\cmd -> cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Many as)] }) + +sqlSet :: (MonadState v m, SqlSet v, Show a, ToSQL a) => SQL -> a -> m () +sqlSet name a = sqlSetCmd name (sqlParam a) + +sqlSetInc :: (MonadState v m, SqlSet v) => SQL -> m () +sqlSetInc name = sqlSetCmd name $ name <+> "+ 1" + +sqlSetList :: (MonadState SqlInsert m, Show a, ToSQL a) => SQL -> [a] -> m () +sqlSetList name as = sqlSetCmdList name (map sqlParam as) + +sqlSetListWithDefaults :: (MonadState SqlInsert m, Show a, ToSQL a) => SQL -> [Maybe a] -> m () +sqlSetListWithDefaults name as = sqlSetCmdList name (map (maybe "DEFAULT" sqlParam) as) + +sqlCopyColumn :: (MonadState v m, SqlSet v) => SQL -> m () +sqlCopyColumn column = sqlSetCmd column column + +class SqlResult a where + sqlResult1 :: a -> SQL -> a + +instance SqlResult SqlSelect where + sqlResult1 cmd sql = cmd { sqlSelectResult = sqlSelectResult cmd ++ [sql] } + +instance SqlResult SqlInsert where + sqlResult1 cmd sql = cmd { sqlInsertResult = sqlInsertResult cmd ++ [sql] } + +instance SqlResult SqlInsertSelect where + sqlResult1 cmd sql = cmd { sqlInsertSelectResult = sqlInsertSelectResult cmd ++ [sql] } + +instance SqlResult SqlUpdate where + sqlResult1 cmd sql = cmd { sqlUpdateResult = sqlUpdateResult cmd ++ [sql] } + + + +sqlResult :: (MonadState v m, SqlResult v) => SQL -> m () +sqlResult sql = modify (\cmd -> sqlResult1 cmd sql) + +class SqlOrderBy a where + sqlOrderBy1 :: a -> SQL -> a + +instance SqlOrderBy SqlSelect where + sqlOrderBy1 cmd sql = cmd { sqlSelectOrderBy = sqlSelectOrderBy cmd ++ [sql] } + +instance SqlOrderBy SqlInsertSelect where + sqlOrderBy1 cmd sql = cmd { sqlInsertSelectOrderBy = sqlInsertSelectOrderBy cmd ++ [sql] } + + +sqlOrderBy :: (MonadState v m, SqlOrderBy v) => SQL -> m () +sqlOrderBy sql = modify (\cmd -> sqlOrderBy1 cmd sql) + +class SqlGroupByHaving a where + sqlGroupBy1 :: a -> SQL -> a + sqlHaving1 :: a -> SQL -> a + +instance SqlGroupByHaving SqlSelect where + sqlGroupBy1 cmd sql = cmd { sqlSelectGroupBy = sqlSelectGroupBy cmd ++ [sql] } + sqlHaving1 cmd sql = cmd { sqlSelectHaving = sqlSelectHaving cmd ++ [sql] } + +instance SqlGroupByHaving SqlInsertSelect where + sqlGroupBy1 cmd sql = cmd { sqlInsertSelectGroupBy = sqlInsertSelectGroupBy cmd ++ [sql] } + sqlHaving1 cmd sql = cmd { sqlInsertSelectHaving = sqlInsertSelectHaving cmd ++ [sql] } + +sqlGroupBy :: (MonadState v m, SqlGroupByHaving v) => SQL -> m () +sqlGroupBy sql = modify (\cmd -> sqlGroupBy1 cmd sql) + +sqlHaving :: (MonadState v m, SqlGroupByHaving v) => SQL -> m () +sqlHaving sql = modify (\cmd -> sqlHaving1 cmd sql) + + +class SqlOffsetLimit a where + sqlOffset1 :: a -> Integer -> a + sqlLimit1 :: a -> Integer -> a + +instance SqlOffsetLimit SqlSelect where + sqlOffset1 cmd num = cmd { sqlSelectOffset = num } + sqlLimit1 cmd num = cmd { sqlSelectLimit = num } + +instance SqlOffsetLimit SqlInsertSelect where + sqlOffset1 cmd num = cmd { sqlInsertSelectOffset = num } + sqlLimit1 cmd num = cmd { sqlInsertSelectLimit = num } + +sqlOffset :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m () +sqlOffset val = modify (\cmd -> sqlOffset1 cmd $ toInteger val) + +sqlLimit :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m () +sqlLimit val = modify (\cmd -> sqlLimit1 cmd $ toInteger val) + +class SqlDistinct a where + sqlDistinct1 :: a -> a + +instance SqlDistinct SqlSelect where + sqlDistinct1 cmd = cmd { sqlSelectDistinct = True } + +instance SqlDistinct SqlInsertSelect where + sqlDistinct1 cmd = cmd { sqlInsertSelectDistinct = True } + +sqlDistinct :: (MonadState v m, SqlDistinct v) => m () +sqlDistinct = modify (\cmd -> sqlDistinct1 cmd) + + +class (SqlWhere a, Sqlable a) => SqlTurnIntoSelect a where + sqlTurnIntoSelect :: a -> SqlSelect + +instance SqlTurnIntoSelect SqlSelect where + sqlTurnIntoSelect = id + + +-- | The 'sqlTurnIntoWhyNotSelect' turn a failed query into a +-- why-not-query that can explain why query altered zero rows or +-- returned zero results. +-- +-- Lets consider an example of explanation: +-- +-- > UPDATE t1 +-- > SET a = 1 +-- > WHERE cond1 +-- > AND cond2 -- with value2 +-- > AND EXISTS (SELECT TRUE +-- > FROM t2 +-- > WHERE cond3 -- with value3a and value3b +-- > AND EXISTS (SELECT TRUE +-- > FROM t3 +-- > WHERE cond4)) +-- +-- sqlTurnIntoWhyNotSelect will produce a SELECT of the form: +-- +-- > SELECT +-- > EXISTS (SELECT TRUE ... WHERE cond1), +-- > EXISTS (SELECT TRUE ... WHERE cond1 AND cond2), +-- > EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3), +-- > EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3 AND cond4); +-- +-- Now, after this statement is executed we see which of these +-- returned FALSE as the first one. This is the condition that failed +-- the whole query. +-- +-- We can get more information at this point. If failed condition was +-- cond2, then value2 can be extracted by this statement: +-- +-- > SELECT value2 ... WHERE cond1; +-- +-- If failed condition was cond3, then statement executed can be: +-- +-- > SELECT value3a, value3b ... WHERE cond1 AND cond2; +-- +-- Rationale: EXISTS clauses should pinpoint which condX was the first +-- one to produce zero rows. SELECT clauses after EXISTS should +-- explain why condX filtered out all rows. +-- +-- 'DB.WhyNot.kWhyNot1' looks for first EXISTS clause that is FALSE +-- and then tries to construct Exception object with values that come +-- after. If values that comes after cannot be sensibly parsed +-- (usually they are NULL when a value is expected), this exception is +-- skipped and next one is tried. +-- +-- If first EXISTS clause is TRUE but no other exception was properly +-- generated then DBExceptionCouldNotParseValues is thrown with pair +-- of typeRef of first exception that could not be parsed and with +-- list of SqlValues that it could not parse. +-- +-- The 'DB.WhyNot.kRun1OrThrowWhyNot' throws first exception on the +-- list. +-- +-- We have a theorem to use in this transformation: +-- +-- > EXISTS (SELECT t1 WHERE cond1 AND EXISTS (SELECT t2 WHERE cond2)) +-- +-- is equivalent to +-- +-- > EXISTS (SELECT t1, t2 WHERE cond1 AND cond2) +-- +-- and it can be used recursivelly. +sqlTurnIntoWhyNotSelect :: (SqlTurnIntoSelect a) => a -> SqlSelect +sqlTurnIntoWhyNotSelect command = + sqlSelect "" . sqlResult $ mconcat [ + "ARRAY[" + , mintercalate ", " $ map emitExists [0..(count-1)] + , "]::boolean[]" + ] + where select = sqlTurnIntoSelect command + count :: Int + count = sum (map count' (sqlSelectWhere select)) + count' (SqlPlainCondition {}) = 1 + count' (SqlExistsCondition select') = sum (map count' (sqlSelectWhere select')) + + emitExists :: Int -> SQL + emitExists current = + case runState (run current select) 0 of + (s, _) -> if null (sqlSelectWhere s) + then "TRUE" + else "EXISTS (" <> (toSQLCommand $ s { sqlSelectResult = [ "TRUE" ]}) <> ")" + + run :: (MonadState Int m) => Int -> SqlSelect -> m SqlSelect + run current select' = do + new <- mapM (around current) (sqlSelectWhere select') + return (select' { sqlSelectWhere = concat new }) + + around :: (MonadState Int m) => Int -> SqlCondition -> m [SqlCondition] + around current cond@(SqlPlainCondition{}) = do + index <- get + modify (+1) + if current >= index + then return [cond] + else return [] + around current (SqlExistsCondition subSelect) = do + subSelect' <- run current subSelect + return [SqlExistsCondition subSelect'] + + +instance SqlTurnIntoSelect SqlUpdate where + sqlTurnIntoSelect s = SqlSelect + { sqlSelectFrom = sqlUpdateWhat s <> + if isSqlEmpty (sqlUpdateFrom s) + then "" + else "," <+> sqlUpdateFrom s + , sqlSelectDistinct = False + , sqlSelectResult = if null (sqlUpdateResult s) + then ["TRUE"] + else sqlUpdateResult s + , sqlSelectWhere = sqlUpdateWhere s + , sqlSelectOrderBy = [] + , sqlSelectGroupBy = [] + , sqlSelectHaving = [] + , sqlSelectOffset = 0 + , sqlSelectLimit = -1 + , sqlSelectWith = sqlUpdateWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE + } + +instance SqlTurnIntoSelect SqlDelete where + sqlTurnIntoSelect s = SqlSelect + { sqlSelectFrom = sqlDeleteFrom s <> + if isSqlEmpty (sqlDeleteUsing s) + then "" + else "," <+> sqlDeleteUsing s + , sqlSelectDistinct = False + , sqlSelectResult = if null (sqlDeleteResult s) + then ["TRUE"] + else sqlDeleteResult s + , sqlSelectWhere = sqlDeleteWhere s + , sqlSelectOrderBy = [] + , sqlSelectGroupBy = [] + , sqlSelectHaving = [] + , sqlSelectOffset = 0 + , sqlSelectLimit = -1 + , sqlSelectWith = sqlDeleteWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE + } + +instance SqlTurnIntoSelect SqlInsertSelect where + sqlTurnIntoSelect s = SqlSelect + { sqlSelectFrom = sqlInsertSelectFrom s + , sqlSelectDistinct = False + , sqlSelectResult = sqlInsertSelectResult s + , sqlSelectWhere = sqlInsertSelectWhere s + , sqlSelectOrderBy = sqlInsertSelectOrderBy s + , sqlSelectGroupBy = sqlInsertSelectGroupBy s + , sqlSelectHaving = sqlInsertSelectHaving s + , sqlSelectOffset = sqlInsertSelectOffset s + , sqlSelectLimit = sqlInsertSelectLimit s + , sqlSelectWith = sqlInsertSelectWith s -- this is a bit dangerous because it can contain nested DELETE/UPDATE + } +{- +data DBExceptionCouldNotParseValues = DBExceptionCouldNotParseValues TypeRep ConvertError [SqlValue] + deriving (Eq, Show, Typeable) + +instance DBExtraException DBExceptionCouldNotParseValues + +instance JSON.ToJSValue DBExceptionCouldNotParseValues where + toJSValue _ = JSON.runJSONGen $ do + JSON.value "message" "DBExceptionCouldNotParseValues" + JSON.value "http_status" (500::Int) + -} +data DBBaseLineConditionIsFalse = DBBaseLineConditionIsFalse SQL + deriving (Show, Typeable) + +instance DBExtraException DBBaseLineConditionIsFalse + +-- +-- It it quite tempting to put the offending SQL as text in the JSON +-- that we produce. This would aid debugging greatly, but could +-- possibly also reveal too much information to a potential attacker. +instance JSON.ToJSValue DBBaseLineConditionIsFalse where + toJSValue _sql = JSON.runJSONGen $ do + JSON.value "message" ("DBBaseLineConditionIsFalse"::String) + +{- Warning: use kWhyNot1 for now as kWhyNot does not work in expected way. + +kWhyNot should return a list of rows, where each row is a list of +exceptions. Right now we are not able to differentiate between rows +because we do not support a concept of a row identity. kWhyNot can +return rows in any order, returns empty rows for successful hits, does +not return a row if baseline conditions weren't met. This effectivelly +renders it useless. + +kWhyNot will be resurrected when we get a row identity concept. + +-} + +{- +kWhyNot :: (SqlTurnIntoSelect s, MonadDB m) => s -> m [[SomeDBExtraException]] +kWhyNot cmd = do + let newSelect = sqlTurnIntoWhyNotSelect cmd + if null (sqlSelectResult newSelect) + then return [[]] + else do + kRun_ newSelect + kFold2 (decodeListOfExceptionsFromWhere (sqlGetWhereConditions cmd)) [] +-} + + +-- | DBExtraException and SomeDBExtraException mimic Exception and +-- SomeException but we need our own class and data type to limit its +-- use to only those which describe semantic exceptions. +-- +-- Our data types also feature conversion to json type so that +-- external representation is known in place where exception is +-- defined. +class (Show e, Typeable e, JSON.ToJSValue e) => DBExtraException e where + toDBExtraException :: e -> SomeDBExtraException + toDBExtraException = SomeDBExtraException + fromDBExtraException :: SomeDBExtraException -> Maybe e + fromDBExtraException (SomeDBExtraException e) = cast e + +catchDBExtraException :: (MonadBaseControl IO m, DBExtraException e) => m a -> (e -> m a) -> m a +catchDBExtraException m f = m `E.catch` (\e -> case fromDBExtraException e of + Just ke -> f ke + Nothing -> throw e) + + +data SomeDBExtraException = forall e. (Show e, DBExtraException e) => SomeDBExtraException e + deriving Typeable + +deriving instance Show SomeDBExtraException + +instance Exception SomeDBExtraException where + toException = SomeException + fromException (SomeException e) = msum [ cast e + , do + DBException {dbeError = e'} <- cast e + cast e' + ] + +{- +instance Show SomeDBExtraException where + show (SomeDBExtraException e) = show e +-} + +-- | Function kWhyNot1 is a workhorse for explainable SQL +-- failures. SQL fails if it did not affect any rows or did no return +-- any rows. When that happens kWhyNot1 should be called. kWhyNot1 +-- returns a list of exceptions describing why a row could not be +-- returned or affected by a query. +-- +-- If kWhyNot1 returns empty list of exception when none of EXISTS +-- clauses generated by sqlTurnIntoWhyNotSelect was FALSE. Should not +-- happen in real life, file a bug report if you see such a case. +-- + +data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeDBExtraException) + +kWhyNot1Ex :: forall m s. (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) + => s -> m (Bool, SomeDBExtraException) +kWhyNot1Ex cmd = do + let newSelect = sqlTurnIntoSelect cmd + newWhyNotSelect = sqlTurnIntoWhyNotSelect newSelect + let findFirstFalse :: Identity (Array1 Bool) -> Int + findFirstFalse (Identity (Array1 row)) = fromMaybe 0 (findIndex (== False) row) + runQuery_ (newWhyNotSelect { sqlSelectLimit = 1 }) + indexOfFirstFailedCondition <- fetchOne findFirstFalse + + let logics = enumerateWhyNotExceptions ((sqlSelectFrom newSelect),[]) (sqlGetWhereConditions newSelect) + + let condition = logics !! (indexOfFirstFailedCondition) + + case condition of + (important, ExceptionMaker exception, _from, []) -> return (important, exception $ error "kWhyNot1Ex: this argument should've been ignored") + (important, ExceptionMaker exception, (from, conds), sqls) -> do + let statement' = sqlSelect2 from $ do + mapM_ sqlResult sqls + sqlLimit (1::Int) + sqlOffset (0::Int) + statement = statement' { sqlSelectWhere = conds } + --Log.debug $ "Explanation SQL:\n" ++ show statement + runQuery_ statement + result <- fetchOne exception + return (important, result) + +kWhyNot1 :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) + => s -> m SomeDBExtraException +kWhyNot1 cmd = snd `fmap` kWhyNot1Ex cmd + +enumerateWhyNotExceptions :: (SQL, [SqlCondition]) + -> [SqlCondition] + -> [( Bool + , ExceptionMaker + , (SQL, [SqlCondition]) + , [SQL] + )] +enumerateWhyNotExceptions (from,condsUpTillNow) conds = concatMap worker (zip conds (inits conds)) + where + worker (SqlPlainCondition _ (SqlWhyNot b f s), condsUpTillNow2) = + [(b, ExceptionMaker (SomeDBExtraException . f), (from, condsUpTillNow ++ condsUpTillNow2), s)] + worker (SqlExistsCondition s, condsUpTillNow2) = + enumerateWhyNotExceptions (newFrom, condsUpTillNow ++ condsUpTillNow2) + (sqlGetWhereConditions s) + where + newFrom = if isSqlEmpty from + then sqlSelectFrom s + else if isSqlEmpty (sqlSelectFrom s) + then from + else from <> ", " <> sqlSelectFrom s + + +kRunManyOrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) + => s -> m () +kRunManyOrThrowWhyNot sqlable = do + success <- runQuery $ toSQLCommand sqlable + when (success == 0) $ do + exception <- kWhyNot1 sqlable + throwDB exception + + +kRun1OrThrowWhyNot :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) + => s -> m () +kRun1OrThrowWhyNot sqlable = do + success <- runQuery01 $ toSQLCommand sqlable + when (not success) $ do + exception <- kWhyNot1 sqlable + throwDB exception + + +kRun1OrThrowWhyNotAllowIgnore :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m) + => s -> m () +kRun1OrThrowWhyNotAllowIgnore sqlable = do + success <- runQuery01 $ toSQLCommand sqlable + when (not success) $ do + (important, exception) <- kWhyNot1Ex sqlable + when (important) $ + throwDB exception + +kRunAndFetch1OrThrowWhyNot :: (IsSQL s, FromRow row, MonadDB m, MonadThrow m, SqlTurnIntoSelect s) + => (row -> a) -> s -> m a +kRunAndFetch1OrThrowWhyNot decoder sqlcommand = do + runQuery_ sqlcommand + results <- fetchMany decoder + case results of + [] -> do + exception <- kWhyNot1 sqlcommand + throwDB exception + [r] -> return r + _ -> throwDB AffectedRowsMismatch { + rowsExpected = [(1, 1)] + , rowsDelivered = length results + } diff --git a/src/Database/PostgreSQL/PQTypes/Versions.hs b/src/Database/PostgreSQL/PQTypes/Versions.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Versions.hs @@ -0,0 +1,16 @@ +module Database.PostgreSQL.PQTypes.Versions where + +import Prelude + +import Database.PostgreSQL.PQTypes.Model + +tableVersions :: Table +tableVersions = tblTable { + tblName = "table_versions" + , tblVersion = 1 + , tblColumns = [ + tblColumn { colName = "name", colType = TextT, colNullable = False } + , tblColumn { colName = "version", colType = IntegerT, colNullable = False } + ] + , tblPrimaryKey = pkOnColumn "name" + }