hamsql 0.8.0.0 → 0.9.0.0

raw patch · 18 files changed

+379/−140 lines, 18 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• CHANGELOG +10/−0
• README.md +142/−13
• hamsql.cabal +17/−15
• src/Database/HamSql/Cli.hs +5/−5
• src/Database/HamSql/Internal/DbUtils.hs +55/−11
• src/Database/HamSql/Internal/InquireDeployed.hs +34/−5
• src/Database/HamSql/Internal/PostgresCon.hs +28/−22
• src/Database/HamSql/Internal/Stmt.hs +2/−1
• src/Database/HamSql/Internal/Stmt/Create.hs +10/−37
• src/Database/HamSql/Internal/Stmt/Database.hs +31/−0
• src/Database/HamSql/Internal/Stmt/Drop.hs +0/−15
• src/Database/HamSql/Internal/Stmt/Role.hs +15/−6
• src/Database/HamSql/Internal/Stmt/Table.hs +11/−7
• src/Database/HamSql/Internal/Stmt/Type.hs +3/−0
• src/Database/HamSql/Internal/Utils.hs +4/−0
• src/Database/HamSql/Setup.hs +4/−3
• src/Database/YamSql/Internal/Obj/Role.hs +7/−0
• src/Database/YamSql/Internal/Obj/Schema.hs +1/−0

@@ -1,3 +1,13 @@+v0.9.0.0+  - Fixes DELETE BASE before schema definitions are read (#64)+  - Fixes incorrect naming of sequences for SERIAL emulation+  - Fixes bugs in table constraint statements (#59)+  - Adds listing of blocking connections if database can't be deleted+  - Adds project status description to README+  - Adds link to example project to README+  - Adds bash completion install (closes #63)+  - Adds revocation of role memberships (fixes #37)+  - Better internal code structure v0.8.0.0   - Replaces pandoc with doctemplates to halve dependency compile time     Big thanks to @jgm for implementing doctemplates right away!

@@ -1,16 +1,155 @@ HamSql ====== -Interpreter for SQL-structure definitions in Yaml ([YamSql](http://yamsql.readthedocs.io/))+An interpreter for SQL structure definitions in YAML ([YamSql](http://yamsql.readthedocs.io/))  [![build status](https://git.hemio.de/hemio/hamsql/badges/master/build.svg)](https://git.hemio.de/hemio/hamsql/commits/master) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/hamsql.svg?maxAge=2592000)](https://hackage.haskell.org/package/hamsql) [![Hackage](https://img.shields.io/hackage/v/hamsql.svg?maxAge=2592000)](https://hackage.haskell.org/package/hamsql) -## Building HamSql on Debian+## About HamSql -Install haskell compiler and required libraries:+HamSql is a software that parses SQL structures defined in a YAML based language and deploys them on PostgreSQL servers. It allows to maintain PostgreSQL projects in a form more similar to other programming languages. +In contrast to the `CREATE OR REPLACE FUNCTION` approaches, residual structures are deleted, column properties are deleted without explicit definition of the migration and the ordering imposed by dependencies is resolved automatically.++HamSql is on hackage, which means you can build it with `cabal install hamsql`. Please note the build requirements and details at the bottom. HamSql binaries for Linux amd64 are available as [build artifacts](https://git.hemio.de/hemio/hamsql/tags) from our build server.++**HamSql can be used for**++- Neat SQL development with clearer versioning via "one object one file" principle+- More flexible development with features like function and table templates+- On site deployments of SQL structures+- Off-line computation of upgrade strategies for known status quo+- Documentation generation of SQL structures and APIs+++### What is there++- `hamsql install` command that deploys the defined structure+- `hamsql upgrade` command that updates existing structures+  - Per default no data are at risk during upgrade (no column/table deletion)+  - Overwrite via `--permit-data-deletion` possible+  - SQL command ordering that avoids dependency conflicts+  - Complicated dependencies are resolved via trial and error+- `hamsql doc` creates a documentation of the complete sql structure+  - Custom templates can be provided using [doctemplates](https://hackage.haskell.org/package/doctemplates) known from pandoc+  - The build-in template creates [Sphinx and Read the Docs](https://docs.readthedocs.io) ready *.rst* files+- Code basis tailored for the support of many SQL features+- [Basic documentation of the YamSql Language](http://yamsql.readthedocs.io)++### Coming soon++- Support for views and triggers+- Warn about name conflicts for SQL objects before deployment+- Output defining YamSql file for each type of error++### What is missing++Those are all things on the radar but the exact requirements are unclear or the workforce is missing.++- [Support for several other PostgreSQL features](https://git.hemio.de/hemio/hamsql/issues?milestone_title=Support+all+SQL+Features)+- Stable definition of YamSql+- Support for renaming tables and columns+- Covering other strategies required for upgrade+- Unit and integration test as part of YamSql+  - Define scenarios that are loaded into the database+  - Define test and expected result for a function for a scenario+  - Define operations with expected outcome (to tests triggers etc.)++## Example Project++The example project below could be deployed via++    hamsql install -c postgresql:///dbname++Later changes can be pushed via++    hamsql upgrade -c postgresql:///dbname++The default documentation can be written to *docs/* via++    hamsql doc++You can have a look at the [output rendered via Sphinx.](http://yamsql-example-project.readthedocs.io)++Those are the YamSql files for the project:++```yaml+# setup.yml+schemas:+ - math+schema_dirs:+ - schemas+```++```yaml+# schema/math/schema.yml+name: math+description: |+ Some basic math in SQL+```++```yaml+---+# schema/math/function.d/factorial.plsql+name: factorial+description: |+ Factorial function using the+ ``WITH RECURSIVE`` SQL feature.++ Logical definition::++     f(0) = 1+     f(n) = n * f (n - 1)++parameters:+ - name: p_n+   type: int+returns: int+---+RETURN (+  WITH RECURSIVE t AS (+      SELECT 1 AS f, 0 AS n+    UNION ALL+      SELECT f * (n + 1), n + 1 FROM t+  )+  SELECT f FROM t WHERE n=p_n LIMIT 1+);+```++```yaml+---+# schema/math/function.d/erf.py+name: erf +description: |+ Gauss error function++ This function is a wrapper for the+ Python 3 implementation.++parameters:+ - name: x+   type: float+returns: float++language: plpython3u+---+import math+return math.erf(x)++```++## Building HamSql on Debian Stretch++To completely build HamSql from source++    apt install make ghc cabal-install libpq-dev happy+    make+    make install+    +To avoid compiling all the dependencies you can use the following set of debian packages instead of the above ones+ ```sh apt install \  make \@@ -26,14 +165,4 @@  libghc-unordered-containers-dev \  libghc-yaml-dev ```--Now you can--    make-    make install--Completly building from sources--    apt install make ghc cabal-install libpq-dev happy-    make 

@@ -1,8 +1,8 @@ name:                hamsql-version:             0.8.0.0-synopsis:            HamSql+version:             0.9.0.0+synopsis:            Interpreter for SQL-structure definitions in YAML (YamSql) category:            Database-description:         Interpreter for SQL-structure definitions in Yaml (YamSql)+description:         Interpreter for SQL-structure definitions in YAML (YamSql) homepage:            https://git.hemio.de/hemio/hamsql bug-reports:         https://git.hemio.de/hemio/hamsql/issues license:             GPL-3@@ -10,8 +10,9 @@ author:              Michael Herold <quabla@hemio.de> maintainer:          Michael Herold <quabla@hemio.de> copyright:           (c) 2014-2016 Michael Herold et al.+stability:           experimental build-type:          Simple-cabal-version:       >=1.10+cabal-version:       >=1.20  extra-source-files:   AUTHORS,@@ -48,22 +49,26 @@     Database.HamSql.Internal.Option     Database.HamSql.Internal.PostgresCon     Database.HamSql.Internal.Stmt+    Database.HamSql.Internal.Utils+    Database.HamSql.Setup+    Database.YamSql+    Database.YamSql.Internal.Basic+    Database.YamSql.Internal.Commons+    Database.YamSql.Internal.SqlId+    Database.YamSql.Parser++  other-modules:     Database.HamSql.Internal.Stmt.Basic     Database.HamSql.Internal.Stmt.Commons     Database.HamSql.Internal.Stmt.Create+    Database.HamSql.Internal.Stmt.Database     Database.HamSql.Internal.Stmt.Domain-    Database.HamSql.Internal.Stmt.Drop     Database.HamSql.Internal.Stmt.Function     Database.HamSql.Internal.Stmt.Role     Database.HamSql.Internal.Stmt.Schema     Database.HamSql.Internal.Stmt.Sequence     Database.HamSql.Internal.Stmt.Table     Database.HamSql.Internal.Stmt.Type-    Database.HamSql.Internal.Utils-    Database.HamSql.Setup-    Database.YamSql-    Database.YamSql.Internal.Basic-    Database.YamSql.Internal.Commons     Database.YamSql.Internal.Obj.Check     Database.YamSql.Internal.Obj.Domain     Database.YamSql.Internal.Obj.Function@@ -72,18 +77,15 @@     Database.YamSql.Internal.Obj.Sequence     Database.YamSql.Internal.Obj.Table     Database.YamSql.Internal.Obj.Type-    Database.YamSql.Internal.SqlId-    Database.YamSql.Parser--  other-modules:     Paths_hamsql    build-depends:     aeson >=1.0 && <1.1,     base >=4.8 && <5.0,     bytestring >=0.10 && <0.11,+    containers >=0.5 && <0.6,     directory >=1.2 && <1.3,-    doctemplates ==0.1.*,+    doctemplates >=0.1 && <0.2,     file-embed >=0.0 && <0.1,     filepath >=1.4 && <1.5,     frontmatter >=0.1 && <0.2,

@@ -21,6 +21,7 @@ import Paths_hamsql (version)  import Database.HamSql+import Database.HamSql.Internal.Stmt.Database import Database.YamSql  parserPrefs :: ParserPrefs@@ -44,6 +45,8 @@     "For installs either both --permit-data-deletion and --delete-existing-database" <->     "must be supplied or non of them."   | otherwise = do+    setup <- loadSetup optCommon (optSetup optCommon)+    stmts <- pgsqlGetFullStatements optCommon setup     let dbname = SqlName $ T.pack $ tail $ uriPath $ getConUrl optDb     if not (optEmulate optDb || optPrint optDb)       then void $@@ -53,15 +56,12 @@               { uriPath = "/postgres"               })              (catMaybes $-              sqlCreateDatabase (optDeleteExistingDatabase optInstall) dbname)+              stmtsCreateDatabase (optDeleteExistingDatabase optInstall) dbname)       else when (optDeleteExistingDatabase optInstall) $            warn' $            "In --emulate and --print mode the DROP/CREATE DATABASE" <->            "statements are skipped. You have to ensure that an empty" <->            "database exists for those commands to make sense."-    setup <- loadSetup optCommon (optSetup optCommon)-    stmts <- pgsqlGetFullStatements optCommon optDb setup-    -- TODO: Own option for this     dropRoleStmts <-       if optDeleteResidualRoles optInstall         then pgsqlDropAllRoleStmts optDb setup@@ -72,7 +72,7 @@   setup <- loadSetup optCommon (optSetup optCommon)   conn <- pgsqlConnectUrl (getConUrl optDb)   deleteStmts <- pgsqlDeleteAllStmt conn-  createStmts <- pgsqlGetFullStatements optCommon optDb setup+  createStmts <- pgsqlGetFullStatements optCommon setup   fragile <- pgsqlUpdateFragile setup conn createStmts   let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)   useSqlStmts optCommon optDb stmts

@@ -8,19 +8,23 @@ module Database.HamSql.Internal.DbUtils where  import Control.Exception+import Control.Monad import qualified Data.ByteString.Char8 as B import Data.String import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.IO as TIO import Database.PostgreSQL.Simple-import Network.URI (URI, parseAbsoluteURI, uriToString)+import Network.URI (URI (..), parseAbsoluteURI, uriToString)  import Database.HamSql.Internal.Option import Database.HamSql.Internal.Stmt import Database.HamSql.Internal.Utils import Database.YamSql +sqlErrObjectInUse :: B.ByteString+sqlErrObjectInUse = "55006"+ toQry :: Text -> Query toQry = fromString . T.unpack @@ -31,8 +35,19 @@     Just filename -> TIO.appendFile filename (x <> "\n")  getConUrl :: OptCommonDb -> URI-getConUrl xs =-  fromJustReason "Not a valid URI" (parseAbsoluteURI $ optConnection xs)+getConUrl optDb = appendQuery "application_name=hamsql" uri+  where+    uri =+      fromJustReason "Not a valid URI" (parseAbsoluteURI $ optConnection optDb)+    appendQuery v u =+      u+      { uriQuery =+        (case maybeHead $ uriQuery u of+           Just '?' -> "&"+           Just _ -> err $ "invalid URI" <-> tshow u+           Nothing -> "?") <>+        v+      }  pgsqlExecStmt :: Connection -> SqlStmt -> IO () pgsqlExecStmt conn stmt = do@@ -42,7 +57,7 @@  pgsqlExecStmtHandled :: Connection -> SqlStmt -> IO () pgsqlExecStmtHandled conn stmt =-  pgsqlExecStmt conn stmt `catch` pgsqlHandleErr stmt+  pgsqlExecStmt conn stmt `catch` pgsqlHandleErr stmt conn  data PgSqlMode   = PgSqlWithoutTransaction@@ -69,16 +84,45 @@           showCode (decodeUtf8 (sqlErrorMsg e))         Right conn -> conn -pgsqlHandleErr :: SqlStmt -> SqlError -> IO ()-pgsqlHandleErr stmt e = do+pgsqlHandleErr :: SqlStmt -> Connection -> SqlError -> IO ()+pgsqlHandleErr stmt conn e = do+  extraMsg <-+    if sqlState e == sqlErrObjectInUse && stmtIdType stmt == SqlDropDatabase+      then do+        xs :: [(SqlName, SqlName, Text)] <-+          query_+            conn+            "SELECT datname, usename, application_name FROM pg_stat_activity WHERE pid <> pg_backend_pid()"+        return $+          "The following existing connection(s) might have caused the error:" <\>+          T.intercalate+            "\n"+            (map showConnected $+             filter (\(db, _, _) -> toSqlCode db == sqlIdCode stmt) xs)+      else return ""   _ <-     err $     "An SQL error occured while executing the following statement" <>     showCode (toSqlCode stmt) <\>-    "The SQL-Server reported" <>-    showCode (decodeUtf8 (sqlErrorMsg e)) <->-    "(Error Code: " <>-    decodeUtf8 (sqlState e) <>-    ")" <\>+    "The SQL-Server reported" <\>+    "Message:" <>+    showCode (decodeUtf8 (sqlErrorMsg e)) <\>+    "Code: " <>+    showCode (decodeUtf8 (sqlState e)) <\>+    errDetail <\>+    errHint <\>+    extraMsg <\>     "\nAll statements have been rolled back if possible."   return ()+  where+    showConnected (_, role, app) = " - role" <-> toSqlCode role <> appOut app+    appOut "" = ""+    appOut x = " via application '" <> x <> "'"+    errDetail =+      case sqlErrorDetail e of+        "" -> ""+        x -> "Detail:" <> showCode (decodeUtf8 x)+    errHint =+      case sqlErrorHint e of+        "" -> ""+        x -> "Hint:" <> showCode (decodeUtf8 x)

@@ -45,6 +45,15 @@       " ON c.contypid = d.oid" <->       sqlManageSchemaJoin "c.connamespace" +-- | List SCHEMA+deployedSchemaIds :: Connection -> IO [SqlObj SQL_SCHEMA SqlName]+deployedSchemaIds conn = map toSqlCodeId <$> query_ conn qry+  where+    toSqlCodeId (Only s) = SqlObj SQL_SCHEMA s+    qry =+      toQry $+      "SELECT s.nspname FROM pg_namespace AS s" <\> sqlManageSchemaJoin "s.oid"+ -- | List SEQUENCE deployedSequenceIds :: Connection -> IO [SqlObj SQL_SEQUENCE SqlName] deployedSequenceIds conn = map toSqlCodeId <$> query_ conn qry@@ -94,18 +103,38 @@  -- | List ROLE deployedRoleIds :: Setup -> Connection -> IO [SqlObj SQL_ROLE SqlName]-deployedRoleIds setup conn = do-  roles <--    query conn "SELECT rolname FROM pg_roles WHERE rolname LIKE ?" $-    Only $ prefix <> "%"-  return $ map toSqlCodeId roles+deployedRoleIds setup conn =+  map toSqlCodeId <$> query conn qry (Only $ prefix <> "%")   where+    qry = "SELECT rolname FROM pg_roles WHERE rolname LIKE ?"     prefix = setupRolePrefix' setup     unprefixed =       fromJustReason "Retrived role without prefix from database" .       stripPrefix prefix     toSqlCodeId (Only role) = SqlObj SQL_ROLE (SqlName $ unprefixed role) +deployedRoleMemberIds :: Setup+                      -> Connection+                      -> IO [SqlObj SQL_ROLE_MEMBERSHIP (SqlName, SqlName)]+deployedRoleMemberIds setup conn =+  map toSqlCodeId <$> query conn qry (prefix <> "%", prefix <> "%")+  where+    prefix = setupRolePrefix' setup+    unprefixed =+      fromJustReason "Retrived role without prefix from database" .+      stripPrefix prefix+    toSqlCodeId (role, member) =+      SqlObj+        SQL_ROLE_MEMBERSHIP+        (SqlName $ unprefixed role, SqlName $ unprefixed member)+    qry =+      toQry $+      "SELECT a.rolname, b.rolname FROM pg_catalog.pg_auth_members AS m" <\>+      " INNER JOIN pg_catalog.pg_roles AS a ON a.oid=m.roleid" <\>+      " INNER JOIN pg_catalog.pg_roles AS b ON b.oid=m.member" <\>+      "WHERE a.rolname LIKE ? AND b.rolname LIKE ?"++-- | List DOMAIN deployedDomainIds :: Connection -> IO [SqlObj SQL_DOMAIN SqlName] deployedDomainIds conn = map toSqlCodeId <$> query_ conn qry   where

@@ -77,10 +77,11 @@ import Control.Monad import qualified Data.ByteString.Char8 as B import Data.Maybe+import Data.Set (fromList, notMember) import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Transaction -import Network.URI (URI)+import Network.URI (URI, uriPath)  import Database.HamSql.Internal.DbUtils import Database.HamSql.Internal.InquireDeployed@@ -88,7 +89,6 @@ import Database.HamSql.Internal.Stmt import Database.HamSql.Internal.Stmt.Create import Database.HamSql.Internal.Stmt.Domain-import Database.HamSql.Internal.Stmt.Drop import Database.HamSql.Internal.Stmt.Function import Database.HamSql.Internal.Stmt.Role import Database.HamSql.Internal.Stmt.Sequence@@ -100,8 +100,8 @@ sqlErrInvalidFunctionDefinition :: B.ByteString sqlErrInvalidFunctionDefinition = "42P13" -pgsqlGetFullStatements :: OptCommon -> OptCommonDb -> Setup -> IO [SqlStmt]-pgsqlGetFullStatements optCom _ setup =+pgsqlGetFullStatements :: OptCommon -> Setup -> IO [SqlStmt]+pgsqlGetFullStatements optCom setup =   return $ catMaybes $ getSetupStatements optCom setup  pgsqlDeleteAllStmt :: Connection -> IO [SqlStmt]@@ -120,8 +120,12 @@   correctStmts SqlAddColumn deployedTableColumnIds stmtsDropTableColumn >>=   correctStmts SqlCreateSequence deployedSequenceIds stmtsDropSequence >>=   correctStmts SqlCreateRole (deployedRoleIds setup) (stmtsDropRole setup) >>=+  correctStmts+    SqlGrantMembership+    (deployedRoleMemberIds setup)+    (stmtRevokeMembership setup) >>=   dropResidual SqlCreateFunction deployedFunctionIds stmtsDropFunction >>=-  revokeAllPrivileges setup (deployedRoleIds setup conn)+  revokeAllPrivileges conn setup (deployedRoleIds setup conn)   where     correctStmts       :: ToSqlId a@@ -141,12 +145,15 @@       -> IO [SqlStmt]     dropResidual t isf f xs = addDropResidual t (isf conn) f xs -revokeAllPrivileges :: Setup+revokeAllPrivileges :: Connection+                    -> Setup                     -> IO [SqlObj SQL_ROLE SqlName]                     -> [SqlStmt]                     -> IO [SqlStmt]-revokeAllPrivileges setup roles stmts =-  (++ stmts) <$> catMaybes <$> concatMap (stmtsDropAllPrivileges setup) <$> roles+revokeAllPrivileges conn setup roles stmts = do+  schemas <- map (\(SqlObj SQL_SCHEMA x) -> x) <$> deployedSchemaIds conn+  ((++ stmts) <$> catMaybes) . concatMap (stmtsDropAllPrivileges setup schemas) <$>+    roles  pgsqlDropAllRoleStmts :: OptCommonDb -> Setup -> IO [SqlStmt] pgsqlDropAllRoleStmts optDb setup = do@@ -240,24 +247,23 @@   | x <- xs   , stmtIdType x == t ] -removeStmtsMatchingIds+filterStmtsMatchingIds   :: [SqlStmtId] -- ^ Statement ids to remove   -> [SqlStmt]   -> [SqlStmt]-removeStmtsMatchingIds ids stmts =-  [ stmt-  | stmt <- stmts-  , stmtId stmt `notElem` ids ]+filterStmtsMatchingIds ids = filter (\x -> stmtId x `notMember` ids')+  where+    ids' = fromList ids -removeSqlIdBySqlStmts+filterSqlIdBySqlStmts   :: ToSqlId a-  => SqlStmtType -> [SqlStmt] -> [a] -> [a]-removeSqlIdBySqlStmts t xs is =-  [ x-  | x <- is-  , sqlId x `notElem` ids ]+  => SqlStmtType -- ^ stmts to be considered by stmt type+  -> [SqlStmt] -- ^ stmts that have the forbidden ids+  -> [a] -- elements that get filtered+  -> [a]+filterSqlIdBySqlStmts t xs = filter (\x -> sqlId x `notMember` ids)   where-    ids = map sqlId $ filterSqlStmtType t xs+    ids = fromList . map sqlId $ filterSqlStmtType t xs  -- target set of sql ids correctStatements@@ -270,7 +276,7 @@ correctStatements t iois f xs = do   is <- iois   xs' <- addDropResidual t iois f xs-  return $ removeStmtsMatchingIds (addSqlStmtType t is) xs'+  return $ filterStmtsMatchingIds (addSqlStmtType t is) xs'  addDropResidual   :: ToSqlId a@@ -281,4 +287,4 @@   -> IO [SqlStmt] addDropResidual t iois f xs = do   is <- iois-  return $ xs ++ catMaybes (concatMap f (removeSqlIdBySqlStmts t xs is))+  return $ xs ++ catMaybes (concatMap f (filterSqlIdBySqlStmts t xs is))

@@ -87,10 +87,11 @@   | SqlPre   | SqlPreInstall   | SqlRevokePrivilege+  | SqlRevokeMembership   | SqlDropRole   | SqlCreateRole   | SqlAlterRole-  | SqlRoleMembership+  | SqlGrantMembership   | SqlCreateSchema   | SqlCreateDomain   | SqlCreateType

@@ -10,6 +10,7 @@ import Database.HamSql.Internal.Stmt import Database.HamSql.Internal.Stmt.Basic import Database.HamSql.Internal.Stmt.Commons ()+import Database.HamSql.Internal.Stmt.Database import Database.HamSql.Internal.Stmt.Domain () import Database.HamSql.Internal.Stmt.Function () import Database.HamSql.Internal.Stmt.Role ()@@ -18,11 +19,9 @@ import Database.HamSql.Internal.Stmt.Table () import Database.HamSql.Internal.Stmt.Type () -fa-  :: Show b-  => Maybe b -> Schema -> [SetupElement]-fa source schema =-  [toSetupElement $ SqlContext schema] +++allSchemaElements :: Schema -> [SetupElement]+allSchemaElements schema =+  [SetupElement $ SqlContext schema] ++   toElemList' schemaRoles schema ++   toElemList schemaDomains schema ++   toElemList schemaFunctions schema ++@@ -30,17 +29,15 @@   toElemList schemaTables schema ++   toElemList schemaTypes schema ++   concat-    [ map (toSetupElement . (\x -> SqlContext (schema, table, x))) $+    [ map (SetupElement . (\x -> SqlContext (schema, table, x))) $      tableColumns table     | table <- fromMaybe [] $ schemaTables schema ]   where-    toSetupElement x = SetupElement x source-    toElemList y =-      maybeMap (toSetupElement . (\x -> SqlContext (schema, x))) . y-    toElemList' y = maybeMap (toSetupElement . SqlContext) . y+    toElemList y = maybeMap (SetupElement . (\x -> SqlContext (schema, x))) . y+    toElemList' y = maybeMap (SetupElement . SqlContext) . y -fb :: SetupContext -> [SetupElement] -> [Maybe SqlStmt]-fb x = concatMap (toSqlStmts x)+elementsToStmts :: SetupContext -> [SetupElement] -> [Maybe SqlStmt]+elementsToStmts setupContext = concatMap (toSqlStmts setupContext)  data SQL_OTHER =   SQL_OTHER@@ -49,13 +46,6 @@ instance ToSqlCode SQL_OTHER where   toSqlCode = const "SQL_OTHER" -data SQL_DATABASE =-  SQL_DATABASE-  deriving (SqlObjType, Show)--instance ToSqlCode SQL_DATABASE where-  toSqlCode = const "DATABASE"- emptyName :: SqlId emptyName = SqlId $ SqlObj SQL_OTHER $ SqlName "" @@ -64,23 +54,6 @@   catMaybes [newSqlStmt SqlUnclassified emptyName "BEGIN TRANSACTION"] ++   xs ++ catMaybes [newSqlStmt SqlUnclassified emptyName "COMMIT"] --- | create database-sqlCreateDatabase :: Bool -> SqlName -> [Maybe SqlStmt]-sqlCreateDatabase deleteDatabase dbName =-  [ sqlDelete deleteDatabase-  , newSqlStmt SqlCreateDatabase (SqlId $ SqlObj SQL_DATABASE dbName) $-    "CREATE DATABASE " <> toSqlCode dbName-  , newSqlStmt-      SqlCreateDatabase-      (SqlId $ SqlObj SQL_DATABASE dbName)-      "ALTER DEFAULT PRIVILEGES REVOKE EXECUTE ON FUNCTIONS FROM PUBLIC"-  ]-  where-    sqlDelete True =-      newSqlStmt SqlDropDatabase (SqlId $ SqlObj SQL_DATABASE dbName) $-      "DROP DATABASE IF EXISTS" <-> toSqlCode dbName-    sqlDelete False = Nothing- -- | Setup getSetupStatements :: OptCommon -> Setup -> [Maybe SqlStmt] getSetupStatements opts s =@@ -94,4 +67,4 @@  getSchemaStatements :: OptCommon -> Setup -> Schema -> [Maybe SqlStmt] getSchemaStatements _ setup s =-  fb (SetupContext setup) $ fa (Just ("src" :: String)) s+  elementsToStmts (SetupContext setup) $ allSchemaElements s

@@ -0,0 +1,31 @@+-- This file is part of HamSql+--+-- Copyright 2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+module Database.HamSql.Internal.Stmt.Database where++import Database.HamSql.Internal.Stmt.Basic++data SQL_DATABASE =+  SQL_DATABASE+  deriving (SqlObjType, Show)++instance ToSqlCode SQL_DATABASE where+  toSqlCode = const "DATABASE"++-- | create database+stmtsCreateDatabase :: Bool -> SqlName -> [Maybe SqlStmt]+stmtsCreateDatabase deleteDatabase dbName =+  [ sqlDelete deleteDatabase+  , newSqlStmt SqlCreateDatabase (SqlId $ SqlObj SQL_DATABASE dbName) $+    "CREATE DATABASE " <> toSqlCode dbName+  , newSqlStmt+      SqlCreateDatabase+      (SqlId $ SqlObj SQL_DATABASE dbName)+      "ALTER DEFAULT PRIVILEGES REVOKE EXECUTE ON FUNCTIONS FROM PUBLIC"+  ]+  where+    sqlDelete True =+      newSqlStmt SqlDropDatabase (SqlId $ SqlObj SQL_DATABASE dbName) $+      "DROP DATABASE IF EXISTS" <-> toSqlCode dbName+    sqlDelete False = Nothing

@@ -1,15 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-module Database.HamSql.Internal.Stmt.Drop where--import Database.HamSql.Internal.Stmt.Basic---- TABLE-stmtsDropTable :: SqlObj SQL_TABLE SqlName -> [Maybe SqlStmt]-stmtsDropTable t = [newSqlStmt SqlDropTable t $ "DROP TABLE " <> toSqlCode t]---- TYPE-stmtsDropType :: SqlObj SQL_TYPE SqlName -> [Maybe SqlStmt]-stmtsDropType t = [newSqlStmt SqlDropType t $ "DROP TYPE " <> toSqlCode t]

@@ -14,9 +14,12 @@ stmtsDropRole setup role@(SqlObj _ roleSqlName) =   [newSqlStmt SqlDropRole role $ "DROP ROLE " <> prefixedRole setup roleSqlName] -stmtsDropAllPrivileges :: Setup -> SqlObj SQL_ROLE SqlName -> [Maybe SqlStmt]-stmtsDropAllPrivileges setup x@(SqlObj _ n)-  | schemas == [] = [Nothing]+stmtsDropAllPrivileges :: Setup+                       -> [SqlName]+                       -> SqlObj SQL_ROLE SqlName+                       -> [Maybe SqlStmt]+stmtsDropAllPrivileges setup schemas x@(SqlObj _ n)+  | null schemas = [Nothing]   | otherwise =     [ newSqlStmt SqlRevokePrivilege x $      "REVOKE ALL PRIVILEGES ON ALL" <-> objType <-> "IN SCHEMA" <->@@ -24,9 +27,15 @@      "FROM" <->      prefixedRole setup n     | objType <- ["TABLES", "SEQUENCES", "FUNCTIONS"] ]-  where-    schemas = maybeMap schemaName (setupSchemaData setup) +stmtRevokeMembership :: Setup+                     -> SqlObj SQL_ROLE_MEMBERSHIP (SqlName, SqlName)+                     -> [Maybe SqlStmt]+stmtRevokeMembership setup x@(SqlObj _ (role, member)) =+  [ newSqlStmt SqlRevokeMembership x $+    "REVOKE" <-> prefixedRole setup role <-> "FROM" <-> prefixedRole setup member+  ]+ instance ToSqlStmts (SqlContext Role) where   toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext r) =     [stmtCreateRole, stmtAlterRole, stmtCommentRole] ++@@ -44,7 +53,7 @@         "COMMENT ON ROLE" <-> prefix (roleName r) <-> "IS" <->         toSqlCodeString (roleDescription r)       sqlRoleMembership group =-        newSqlStmt SqlRoleMembership obj $+        newSqlStmt SqlGrantMembership obj $         "GRANT" <-> prefix group <-> "TO" <-> prefix (roleName r)       sqlLogin (Just True) = "LOGIN"       sqlLogin _ = "NOLOGIN"

@@ -5,14 +5,15 @@ {-# LANGUAGE FlexibleInstances #-}  module Database.HamSql.Internal.Stmt.Table-  ( stmtsDropTableConstr+  ( stmtsDropTable+  , stmtsDropTableConstr   , stmtsDropTableColumn   ) where  import qualified Data.Text as T  import Database.HamSql.Internal.Stmt.Basic-import Database.HamSql.Internal.Stmt.Sequence()+import Database.HamSql.Internal.Stmt.Sequence ()  -- | Assuming that CASCADE will only cause other constraints to be deleted. -- | Required since foreign keys may depend on other keys.@@ -25,6 +26,9 @@     "CASCADE"   ] +stmtsDropTable :: SqlObj SQL_TABLE SqlName -> [Maybe SqlStmt]+stmtsDropTable t = [newSqlStmt SqlDropTable t $ "DROP TABLE" <-> toSqlCode t]+ stmtsDropTableColumn :: SqlObj SQL_COLUMN (SqlName, SqlName) -> [Maybe SqlStmt] stmtsDropTableColumn x@(SqlObj _ (t, c)) =   [ newSqlStmt SqlDropTableColumn x $@@ -95,7 +99,7 @@         where           sqlDefault d = stmtAlterColumn SqlAddDefault $ "SET DEFAULT " <> d       -- [CHECK]-      stmtsAddColumnCheck = maybeMap (stmtCheck obj) (columnChecks c)+      stmtsAddColumnCheck = maybeMap (stmtCheck tbl) (columnChecks c)       -- FOREIGN KEY       stmtAddForeignKey =         case columnReferences c of@@ -105,8 +109,7 @@             in newSqlStmt                  SqlCreateForeignKeyConstr                  (constrId schema table constr) $-               "ALTER TABLE" <-> sqlIdCode obj <-> "ADD CONSTRAINT" <->-               toSqlCode constr <->+               "ALTER TABLE" <-> tblId <-> "ADD CONSTRAINT" <-> toSqlCode constr <->                "FOREIGN KEY (" <>                toSqlCode (columnName c) <>                ")" <->@@ -137,13 +140,14 @@             "nextval('" <> toSqlCode (sqlId serialSequenceContext) <> "')"           }         | otherwise = rawColumn-      tblId = toSqlCode $ schemaName schema <.> tableName table+      tblId = sqlIdCode tbl+      tbl = SqlContext (schema, table)       serialSequenceContext =         SqlContext           ( schema           , Sequence             -- sequenceName follows PostgreSQL internal convention-            { sequenceName = tableName table <> columnName c <> SqlName "_seq"+            { sequenceName = tableName table <> columnName c <> SqlName "seq"             , sequenceIncrement = Nothing             , sequenceMinValue = Nothing             , sequenceMaxValue = Nothing

@@ -10,6 +10,9 @@  import Database.HamSql.Internal.Stmt.Basic +stmtsDropType :: SqlObj SQL_TYPE SqlName -> [Maybe SqlStmt]+stmtsDropType t = [newSqlStmt SqlDropType t $ "DROP TYPE" <-> toSqlCode t]+ instance ToSqlStmts (SqlContext (Schema, Type)) where   toSqlStmts _ obj@(SqlContext (_, t)) =     [ newSqlStmt SqlCreateType obj $

@@ -102,6 +102,10 @@ showCode :: Text -> Text showCode = T.replace "\n" "\n  " . T.cons '\n' +maybeHead :: [a] -> Maybe a+maybeHead [] = Nothing+maybeHead (x:_) = Just x+ tr   :: Show a   => a -> a

@@ -22,9 +22,10 @@   { setupContextSetup :: Setup   } -data SetupElement where SetupElement :: (ToSqlStmts a, Show b) => { setupElement :: a-    , setupElementSource :: Maybe b-    } -> SetupElement+data SetupElement where+  SetupElement :: (ToSqlStmts a)+               => { setupElement :: a }+               -> SetupElement  instance ToSqlStmts SetupElement where     toSqlStmts x SetupElement{setupElement=y} = toSqlStmts x y

@@ -29,3 +29,10 @@  instance ToSqlId (SqlContext Role) where   sqlId (SqlContext x) = SqlId $ SqlObj SQL_ROLE (roleName x)++data SQL_ROLE_MEMBERSHIP =+  SQL_ROLE_MEMBERSHIP+  deriving (SqlObjType, Show)++instance ToSqlCode SQL_ROLE_MEMBERSHIP where+  toSqlCode = const "ROLE_MEMBERSHIP"

@@ -6,6 +6,7 @@  module Database.YamSql.Internal.Obj.Schema   ( Schema(..)+  , SQL_SCHEMA(..)   , module Database.YamSql.Internal.Obj.Check   , module Database.YamSql.Internal.Obj.Domain   , module Database.YamSql.Internal.Obj.Function