packages feed

hpqtypes-extras (empty) → 1.2.4

raw patch · 17 files changed

+2486/−0 lines, 17 filesdep +basedep +base16-bytestringdep +bytestringsetup-changed

Dependencies added: base, base16-bytestring, bytestring, containers, cryptohash, exceptions, fields-json, hpqtypes, lifted-base, log, monad-control, mtl, text, text-show

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hpqtypes-extras.cabal view
@@ -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 <andrzej@rybczak.net>,+                     Jonathan Jouty <jonathan@scrive.com>+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
+ src/Database/PostgreSQL/PQTypes/Checks.hs view
@@ -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 <> ": "
+ src/Database/PostgreSQL/PQTypes/Model.hs view
@@ -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+
+ src/Database/PostgreSQL/PQTypes/Model/Check.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/Domain.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/Extension.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/Index.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/Migration.hs view
@@ -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 ()+}
+ src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs view
@@ -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
+ src/Database/PostgreSQL/PQTypes/Model/Table.hs view
@@ -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+  ]
+ src/Database/PostgreSQL/PQTypes/SQL/Builder.hs view
@@ -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+    }
+ src/Database/PostgreSQL/PQTypes/Versions.hs view
@@ -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"+  }