hamsql 0.7.0.0 → 0.8.0.0
raw patch · 42 files changed
+1061/−1085 lines, 42 filesdep +doctemplatesdep −pandocdep −semigroups
Dependencies added: doctemplates
Dependencies removed: pandoc, semigroups
Files
- CHANGELOG +14/−2
- README.md +3/−2
- app/hamsql.hs +11/−0
- hamsql-tests.hs +0/−8
- hamsql.cabal +23/−20
- hamsql.hs +0/−11
- src/Database/HamSql/Cli.hs +1/−1
- src/Database/HamSql/Internal/Documentation.hs +1/−1
- src/Database/HamSql/Internal/InquireDeployed.hs +22/−21
- src/Database/HamSql/Internal/Option.hs +16/−9
- src/Database/HamSql/Internal/PostgresCon.hs +14/−5
- src/Database/HamSql/Internal/Stmt.hs +2/−2
- src/Database/HamSql/Internal/Stmt/Commons.hs +1/−5
- src/Database/HamSql/Internal/Stmt/Create.hs +30/−14
- src/Database/HamSql/Internal/Stmt/Domain.hs +28/−31
- src/Database/HamSql/Internal/Stmt/Drop.hs +2/−2
- src/Database/HamSql/Internal/Stmt/Function.hs +81/−85
- src/Database/HamSql/Internal/Stmt/Role.hs +20/−7
- src/Database/HamSql/Internal/Stmt/Schema.hs +2/−2
- src/Database/HamSql/Internal/Stmt/Sequence.hs +29/−32
- src/Database/HamSql/Internal/Stmt/Table.hs +203/−209
- src/Database/HamSql/Internal/Stmt/Type.hs +12/−15
- src/Database/HamSql/Internal/Utils.hs +7/−3
- src/Database/YamSql.hs +2/−2
- src/Database/YamSql/Internal/Check.hs +0/−27
- src/Database/YamSql/Internal/Domain.hs +0/−26
- src/Database/YamSql/Internal/Function.hs +0/−110
- src/Database/YamSql/Internal/Obj/Check.hs +19/−0
- src/Database/YamSql/Internal/Obj/Domain.hs +33/−0
- src/Database/YamSql/Internal/Obj/Function.hs +107/−0
- src/Database/YamSql/Internal/Obj/Role.hs +31/−0
- src/Database/YamSql/Internal/Obj/Schema.hs +97/−0
- src/Database/YamSql/Internal/Obj/Sequence.hs +28/−0
- src/Database/YamSql/Internal/Obj/Table.hs +125/−0
- src/Database/YamSql/Internal/Obj/Type.hs +40/−0
- src/Database/YamSql/Internal/Role.hs +0/−28
- src/Database/YamSql/Internal/Schema.hs +0/−123
- src/Database/YamSql/Internal/Sequence.hs +0/−28
- src/Database/YamSql/Internal/SqlId.hs +49/−102
- src/Database/YamSql/Internal/Table.hs +0/−115
- src/Database/YamSql/Internal/Type.hs +0/−37
- test/hamsql-tests.hs +8/−0
CHANGELOG view
@@ -1,4 +1,16 @@-v0.7.0+v0.8.0.0+ - Replaces pandoc with doctemplates to halve dependency compile time+ Big thanks to @jgm for implementing doctemplates right away!+ <https://github.com/jgm/pandoc/issues/3134>+ - Adds --delete-residual-roles option (closes #30)+ - Adds --sql-log-hide-rollbacks option (closes #55)+ - Adds Internal libraries to exposed modules+ - Adds dropping of basic role privileges (#37)+ - Changes YamSql objects to Internal.Obj.* (closes #58)+ - Changes to a better SqlObj and SqlContext structure (closes #60)+ - Changes to treat columns as independent objects (closes #33)+ - Updates README+v0.7.0.0 - Fixes all compiler warnings - Fixes several bugs related to ROLE upgrades - Fixes table checks missing after upgrade@@ -12,7 +24,7 @@ - Removes support for column templates - Splits library from binary (cabal) - Started API and implementation docs-v0.6.0+v0.6.0.0 - Adds resolve complicated dependency issues - Adds resolve change of function return type (if function can be dropped) - Changes connection options to suppress SQL NOTICE messages
README.md view
@@ -3,8 +3,9 @@ Interpreter for SQL-structure definitions in Yaml ([YamSql](http://yamsql.readthedocs.io/)) -- [](https://git.hemio.de/hemio/hamsql/commits/master) *Debian Stable*-- [](https://travis-ci.org/qua-bla/hamsql) *GHC 7.6, 7.8*+[](https://git.hemio.de/hemio/hamsql/commits/master)+[](https://hackage.haskell.org/package/hamsql)+[](https://hackage.haskell.org/package/hamsql) ## Building HamSql on Debian
+ app/hamsql.hs view
@@ -0,0 +1,11 @@+-- This file is part of HamSql+--+-- Copyright 2014-2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+module Main where++import Database.HamSql.Cli++main :: IO ()+main = parseArgv >>= run+
− hamsql-tests.hs
@@ -1,8 +0,0 @@-module Main where--import Database.HamSql.Cli--main :: IO ()-main = do- exec ["--help"] - where exec xs = parseThisArgv xs >>= run
hamsql.cabal view
@@ -1,5 +1,5 @@ name: hamsql-version: 0.7.0.0+version: 0.8.0.0 synopsis: HamSql category: Database description: Interpreter for SQL-structure definitions in Yaml (YamSql)@@ -23,25 +23,24 @@ hs-source-dirs: src default-language: Haskell2010 default-extensions:+ DeriveAnyClass,+ DeriveDataTypeable,+ DeriveGeneric,+ FlexibleContexts,+ FlexibleInstances, OverloadedStrings other-extensions: DeriveDataTypeable, DeriveGeneric,- FlexibleContexts,- FlexibleInstances, GADTs, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell+ exposed-modules: Database.HamSql Database.HamSql.Cli- Database.HamSql.Setup- Database.YamSql- Database.YamSql.Parser-- other-modules: Database.HamSql.Internal.DbUtils Database.HamSql.Internal.Documentation Database.HamSql.Internal.InquireDeployed@@ -61,17 +60,22 @@ 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.Check Database.YamSql.Internal.Commons- Database.YamSql.Internal.Domain- Database.YamSql.Internal.Function- Database.YamSql.Internal.Role- Database.YamSql.Internal.Schema- Database.YamSql.Internal.Sequence+ Database.YamSql.Internal.Obj.Check+ Database.YamSql.Internal.Obj.Domain+ Database.YamSql.Internal.Obj.Function+ Database.YamSql.Internal.Obj.Role+ Database.YamSql.Internal.Obj.Schema+ Database.YamSql.Internal.Obj.Sequence+ Database.YamSql.Internal.Obj.Table+ Database.YamSql.Internal.Obj.Type Database.YamSql.Internal.SqlId- Database.YamSql.Internal.Table- Database.YamSql.Internal.Type+ Database.YamSql.Parser++ other-modules: Paths_hamsql build-depends:@@ -79,22 +83,21 @@ base >=4.8 && <5.0, bytestring >=0.10 && <0.11, directory >=1.2 && <1.3,+ doctemplates ==0.1.*, file-embed >=0.0 && <0.1, filepath >=1.4 && <1.5, frontmatter >=0.1 && <0.2, groom >=0.1 && < 0.2, network-uri >=2.6 && <2.7, optparse-applicative >=0.13 && <0.14,- pandoc >=1.17 && <1.18, postgresql-simple >=0.4 && <0.6,- semigroups >=0.18 && <0.19, text >=1.2 && <1.3, transformers >=0.5 && <0.6, unordered-containers >=0.2 && <0.3, yaml >=0.8 && <0.9 executable hamsql- main-is: hamsql.hs+ main-is: app/hamsql.hs default-language: Haskell2010 build-depends:@@ -104,7 +107,7 @@ test-suite hamsql-tests default-language: Haskell2010 type: exitcode-stdio-1.0- main-is: hamsql-tests.hs+ main-is: test/hamsql-tests.hs build-depends: base >=4.8 && <5.0, hamsql
− hamsql.hs
@@ -1,11 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-module Main where--import Database.HamSql.Cli--main :: IO ()-main = parseArgv >>= run-
src/Database/HamSql/Cli.hs view
@@ -63,7 +63,7 @@ stmts <- pgsqlGetFullStatements optCommon optDb setup -- TODO: Own option for this dropRoleStmts <-- if optDeleteExistingDatabase optInstall+ if optDeleteResidualRoles optInstall then pgsqlDropAllRoleStmts optDb setup else return [] useSqlStmts optCommon optDb $ sort $ stmts ++ dropRoleStmts
src/Database/HamSql/Internal/Documentation.hs view
@@ -11,7 +11,7 @@ import Data.Text.Encoding import qualified Data.Text.IO as T.IO import System.FilePath-import Text.Pandoc.Templates+import Text.DocTemplates import Database.HamSql.Internal.Option import Database.HamSql.Internal.Utils
src/Database/HamSql/Internal/InquireDeployed.hs view
@@ -19,11 +19,12 @@ " NOT n.nspname LIKE 'pg_%' AND " <\> " n.nspname NOT IN ('information_schema') " -deployedTableConstrIds :: Connection -> IO [SqlIdContentSqoObj]+deployedTableConstrIds :: Connection+ -> IO [SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName)] deployedTableConstrIds conn = map toSqlCodeId <$> query_ conn qry where toSqlCodeId (schema, table, constraint) =- SqlIdContentSqoObj "TABLE-CONSTRAINT" (schema <.> table) constraint+ SqlObj SQL_TABLE_CONSTRAINT (schema, table, constraint) qry = toQry $ "SELECT n.nspname, t.relname, c.conname" <\> "FROM pg_constraint AS c" <\>@@ -31,11 +32,12 @@ " ON c.conrelid = t.oid" <-> sqlManageSchemaJoin "c.connamespace" -deployedDomainConstrIds :: Connection -> IO [SqlIdContentSqoObj]+deployedDomainConstrIds :: Connection+ -> IO [SqlObj SQL_DOMAIN_CONSTRAINT (SqlName, SqlName)] deployedDomainConstrIds conn = map toSqlCodeId <$> query_ conn qry where toSqlCodeId (schema, table, constraint) =- SqlIdContentSqoObj "DOMAIN-CONSTRAINT" (schema <.> table) constraint+ SqlObj SQL_DOMAIN_CONSTRAINT (schema <.> table, constraint) qry = toQry $ "SELECT n.nspname, d.typname, c.conname" <\> "FROM pg_constraint AS c " <\>@@ -44,17 +46,17 @@ sqlManageSchemaJoin "c.connamespace" -- | List SEQUENCE-deployedSequenceIds :: Connection -> IO [SqlIdContentSqo]+deployedSequenceIds :: Connection -> IO [SqlObj SQL_SEQUENCE SqlName] deployedSequenceIds conn = map toSqlCodeId <$> query_ conn qry where- toSqlCodeId (s, t) = SqlIdContentSqo "SEQUENCE" $ s <.> t+ toSqlCodeId (s, t) = SqlObj SQL_SEQUENCE (s <.> t) qry = toQry $ "SELECT sequence_schema, sequence_name" <\> "FROM information_schema.sequences" -- | List TABLE-deployedTableIds :: Connection -> IO [SqlIdContentSqo]+deployedTableIds :: Connection -> IO [SqlObj SQL_TABLE SqlName] deployedTableIds conn = do dat <- query_ conn $@@ -64,13 +66,14 @@ " AND table_schema NOT IN ('information_schema', 'pg_catalog')" return $ map toSqlCodeId dat where- toSqlCodeId (s, t) = SqlIdContentSqo "TABLE" $ s <.> t+ toSqlCodeId (s, t) = SqlObj SQL_TABLE (s <.> t) -- | List TABLE COLUMN-deployedTableColumnIds :: Connection -> IO [SqlIdContentSqoObj]+deployedTableColumnIds :: Connection+ -> IO [SqlObj SQL_COLUMN (SqlName, SqlName)] deployedTableColumnIds conn = map toSqlCodeId <$> query_ conn qry where- toSqlCodeId (s, t, u) = SqlIdContentSqoObj "TABLE-COLUMN" (s <.> t) u+ toSqlCodeId (s, t, u) = SqlObj SQL_COLUMN (s <.> t, u) qry = toQry $ "SELECT table_schema, table_name, column_name" <\>@@ -79,10 +82,10 @@ " WHERE table_schema NOT IN ('information_schema', 'pg_catalog')" -- | List TYPE-deployedTypeIds :: Connection -> IO [SqlIdContentSqo]+deployedTypeIds :: Connection -> IO [SqlObj SQL_TYPE SqlName] deployedTypeIds conn = map toSqlCodeId <$> query_ conn qry where- toSqlCodeId (schema, t) = SqlIdContentSqo "TYPE" $ schema <.> t+ toSqlCodeId (s, t) = SqlObj SQL_TYPE (s <.> t) qry = toQry $ "SELECT user_defined_type_schema, user_defined_type_name" <\>@@ -90,7 +93,7 @@ " WHERE user_defined_type_schema NOT IN ('information_schema', 'pg_catalog')" -- | List ROLE-deployedRoleIds :: Setup -> Connection -> IO [SqlIdContentObj]+deployedRoleIds :: Setup -> Connection -> IO [SqlObj SQL_ROLE SqlName] deployedRoleIds setup conn = do roles <- query conn "SELECT rolname FROM pg_roles WHERE rolname LIKE ?" $@@ -101,25 +104,23 @@ unprefixed = fromJustReason "Retrived role without prefix from database" . stripPrefix prefix- toSqlCodeId (Only role) = SqlIdContentObj "ROLE" (SqlName $ unprefixed role)+ toSqlCodeId (Only role) = SqlObj SQL_ROLE (SqlName $ unprefixed role) -deployedDomainIds :: Connection -> IO [SqlIdContentSqo]+deployedDomainIds :: Connection -> IO [SqlObj SQL_DOMAIN SqlName] deployedDomainIds conn = map toSqlCodeId <$> query_ conn qry where- toSqlCodeId (schema, domain) = SqlIdContentSqo "DOMAIN" $ schema <.> domain+ toSqlCodeId (schema, domain) = SqlObj SQL_DOMAIN $ schema <.> domain qry = toQry $ "SELECT domain_schema, domain_name" <\> " FROM information_schema.domains" <\> " WHERE domain_schema NOT IN ('information_schema', 'pg_catalog')" -deployedFunctionIds :: Connection -> IO [SqlIdContentSqoArgtypes]+deployedFunctionIds :: Connection+ -> IO [SqlObj SQL_FUNCTION (SqlName, [SqlType])] deployedFunctionIds conn = map toSqlCodeId <$> query_ conn qry where toSqlCodeId (schema, function, args) =- SqlIdContentSqoArgtypes- "FUNCTION"- (schema <.> function)- (fromPGArray args)+ SqlObj SQL_FUNCTION (schema <.> function, fromPGArray args) qry = toQry $ "SELECT n.nspname, p.proname, " <>
src/Database/HamSql/Internal/Option.hs view
@@ -5,7 +5,7 @@ module Database.HamSql.Internal.Option where import Control.Monad.Trans.Reader-import Data.Semigroup hiding (option)+import Data.Monoid import Options.Applicative import Options.Applicative.Builder.Internal (HasMetavar, HasValue) import Options.Applicative.Types@@ -87,11 +87,12 @@ -- Commons Execute data OptCommonDb = OptCommonDb- { optEmulate :: Bool- , optPrint :: Bool- , optConnection :: String- , optPermitDataDeletion :: Bool- , optSqlLog :: Maybe FilePath+ { optEmulate :: Bool+ , optPrint :: Bool+ , optConnection :: String+ , optPermitDataDeletion :: Bool+ , optSqlLog :: Maybe FilePath+ , optSqlLogHideRollbacks :: Bool } deriving (Show) justStr :: ReadM (Maybe String)@@ -110,14 +111,19 @@ justStr (long "sql-log" <> help- ("If specified, log sql statements to given file. " <>+ ("If specified, log SQL statements to given file. " <> "Existing logfiles will be extended, not deleted.") <> value Nothing <>- metavar "<log file>")+ metavar "<log file>") <*>+ boolFlag+ (long "sql-log-hide-rollbacks" <>+ help+ "Hide ROLLBACK and SAVEPOINT statements. Useful for creating migration code via --log-sql.") -- Command Install data OptInstall = OptInstall { optDeleteExistingDatabase :: Bool+ , optDeleteResidualRoles :: Bool } deriving (Show) parserOptInstall :: Parser OptInstall@@ -125,7 +131,8 @@ OptInstall <$> boolFlag (long "delete-existing-database" <> short 'd' <>- help "Delete database if it allready exists")+ help "Delete database if it allready exists") <*>+ boolFlag (long "delete-residual-roles" <> help "Delete residual roles") -- Command NoCommand data OptNoCommand = OptNoCommand
src/Database/HamSql/Internal/PostgresCon.hs view
@@ -74,7 +74,7 @@ module Database.HamSql.Internal.PostgresCon where import Control.Exception-import Control.Monad (void, when)+import Control.Monad import qualified Data.ByteString.Char8 as B import Data.Maybe import Database.PostgreSQL.Simple@@ -120,7 +120,8 @@ correctStmts SqlAddColumn deployedTableColumnIds stmtsDropTableColumn >>= correctStmts SqlCreateSequence deployedSequenceIds stmtsDropSequence >>= correctStmts SqlCreateRole (deployedRoleIds setup) (stmtsDropRole setup) >>=- dropResidual SqlCreateFunction deployedFunctionIds stmtsDropFunction+ dropResidual SqlCreateFunction deployedFunctionIds stmtsDropFunction >>=+ revokeAllPrivileges setup (deployedRoleIds setup conn) where correctStmts :: ToSqlId a@@ -140,6 +141,13 @@ -> IO [SqlStmt] dropResidual t isf f xs = addDropResidual t (isf conn) f xs +revokeAllPrivileges :: Setup+ -> IO [SqlObj SQL_ROLE SqlName]+ -> [SqlStmt]+ -> IO [SqlStmt]+revokeAllPrivileges setup roles stmts =+ (++ stmts) <$> catMaybes <$> concatMap (stmtsDropAllPrivileges setup) <$> roles+ pgsqlDropAllRoleStmts :: OptCommonDb -> Setup -> IO [SqlStmt] pgsqlDropAllRoleStmts optDb setup = do conn <- pgsqlConnectUrl $ getConUrl optDb@@ -197,9 +205,10 @@ handleQueryError savepoint QueryError {} = proceed savepoint -- action after execution has failed skipQuery savepoint stmts = do- logStmt opt "SAVEPOINT retry;"- logStmt opt $ toSqlCode x- logStmt opt "ROLLBACK TO SAVEPOINT retry;"+ unless (optSqlLogHideRollbacks opt) $+ do logStmt opt "SAVEPOINT retry;"+ logStmt opt $ toSqlCode x+ logStmt opt "ROLLBACK TO SAVEPOINT retry;" rollbackToSavepoint conn savepoint releaseSavepoint conn savepoint pgsqlExecStmtList opt forwardStatus xs (failed ++ stmts) conn
src/Database/HamSql/Internal/Stmt.hs view
@@ -4,7 +4,6 @@ -- Some rights reserved. See COPYING, AUTHORS. {-# LANGUAGE GADTs #-} ---{-# LANGUAGE FlexibleInstances #-} module Database.HamSql.Internal.Stmt where import qualified Data.Text as T@@ -36,7 +35,7 @@ stmtIdType (SqlStmt x _) = stmtType x stmtDesc :: SqlStmt -> Text-stmtDesc stmt = sqlIdType (sqlId stmt) <-> sqlIdCode stmt+stmtDesc stmt = sqlIdShowType (sqlId stmt) <-> sqlIdCode stmt instance Eq SqlStmt where x == y = stmtId x == stmtId y@@ -87,6 +86,7 @@ | SqlCreateDatabase | SqlPre | SqlPreInstall+ | SqlRevokePrivilege | SqlDropRole | SqlCreateRole | SqlAlterRole
src/Database/HamSql/Internal/Stmt/Commons.hs view
@@ -14,12 +14,8 @@ => a -> Text -> Maybe SqlStmt stmtCommentOn obj comment = newSqlStmt SqlComment obj $- "COMMENT ON " <> rewriteType (sqlIdType (sqlId obj)) <> " " <> sqlIdCode obj <>- " IS " <>+ "COMMENT ON " <> sqlIdTypeCode (sqlId obj) <> " " <> sqlIdCode obj <> " IS " <> toSqlCodeString comment- where- rewriteType "TABLE-COLUMN" = "COLUMN"- rewriteType xs = xs prefixedRole :: Setup -> SqlName -> Text prefixedRole setup role = toSqlCode ((SqlName $ setupRolePrefix' setup) // role)
src/Database/HamSql/Internal/Stmt/Create.hs view
@@ -22,26 +22,42 @@ :: Show b => Maybe b -> Schema -> [SetupElement] fa source schema =- [toSetupElement $ SqlContextObj schema] ++- toElemList' SqlContextObj schemaRoles schema ++- toElemList SqlContextSqo schemaDomains schema ++- toElemList SqlContextSqoArgtypes schemaFunctions schema ++- toElemList SqlContextSqo schemaSequences schema ++- toElemList SqlContextSqo schemaTables schema ++- toElemList SqlContextSqo schemaTypes schema +++ [toSetupElement $ SqlContext schema] +++ toElemList' schemaRoles schema +++ toElemList schemaDomains schema +++ toElemList schemaFunctions schema +++ toElemList schemaSequences schema +++ toElemList schemaTables schema +++ toElemList schemaTypes schema ++ concat- [ map (toSetupElement . SqlContextSqoObj schema table) $ tableColumns table+ [ map (toSetupElement . (\x -> SqlContext (schema, table, x))) $+ tableColumns table | table <- fromMaybe [] $ schemaTables schema ] where toSetupElement x = SetupElement x source- toElemList x y = maybeMap (toSetupElement . x schema) . y- toElemList' x y = maybeMap (toSetupElement . x) . y+ toElemList y =+ maybeMap (toSetupElement . (\x -> SqlContext (schema, x))) . y+ toElemList' y = maybeMap (toSetupElement . SqlContext) . y fb :: SetupContext -> [SetupElement] -> [Maybe SqlStmt] fb x = concatMap (toSqlStmts x) +data SQL_OTHER =+ SQL_OTHER+ deriving (SqlObjType, Show)++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 $ SqlIdContentObj "?" $ SqlName ""+emptyName = SqlId $ SqlObj SQL_OTHER $ SqlName "" sqlAddTransact :: [SqlStmt] -> [SqlStmt] sqlAddTransact xs =@@ -52,16 +68,16 @@ sqlCreateDatabase :: Bool -> SqlName -> [Maybe SqlStmt] sqlCreateDatabase deleteDatabase dbName = [ sqlDelete deleteDatabase- , newSqlStmt SqlCreateDatabase (SqlId $ SqlIdContentObj "DATABASE" dbName) $+ , newSqlStmt SqlCreateDatabase (SqlId $ SqlObj SQL_DATABASE dbName) $ "CREATE DATABASE " <> toSqlCode dbName , newSqlStmt SqlCreateDatabase- (SqlId $ SqlIdContentObj "DATABASE" dbName)+ (SqlId $ SqlObj SQL_DATABASE dbName) "ALTER DEFAULT PRIVILEGES REVOKE EXECUTE ON FUNCTIONS FROM PUBLIC" ] where sqlDelete True =- newSqlStmt SqlDropDatabase (SqlId $ SqlIdContentObj "DATABASE" dbName) $+ newSqlStmt SqlDropDatabase (SqlId $ SqlObj SQL_DATABASE dbName) $ "DROP DATABASE IF EXISTS" <-> toSqlCode dbName sqlDelete False = Nothing
src/Database/HamSql/Internal/Stmt/Domain.hs view
@@ -8,38 +8,35 @@ import Database.HamSql.Internal.Stmt.Basic -stmtsDropDomain :: SqlIdContentSqo -> [Maybe SqlStmt]+stmtsDropDomain :: SqlObj SQL_DOMAIN SqlName -> [Maybe SqlStmt] stmtsDropDomain x = [newSqlStmt SqlDropDomain x $ "DROP DOMAIN" <-> toSqlCode x] -stmtsDropDomainConstr :: SqlIdContentSqoObj -> [Maybe SqlStmt]-stmtsDropDomainConstr x =- [ newSqlStmt SqlDropDomainConstr x $- "ALTER DOMAIN" <-> sqlSqoIdCode x <-> "DROP CONSTRAINT" <->- sqlSqoObjIdCode x+stmtsDropDomainConstr :: SqlObj SQL_DOMAIN_CONSTRAINT (SqlName, SqlName)+ -> [Maybe SqlStmt]+stmtsDropDomainConstr obj@(SqlObj _ (d, c)) =+ [ newSqlStmt SqlDropDomainConstr obj $+ "ALTER DOMAIN" <-> toSqlCode d <-> "DROP CONSTRAINT" <-> toSqlCode c ] -instance ToSqlStmts (SqlContextSqo Domain) where- toSqlStmts = stmtsDeployDomain--stmtsDeployDomain :: SetupContext -> SqlContextSqo Domain -> [Maybe SqlStmt]-stmtsDeployDomain _ obj@SqlContextSqo {sqlSqoObject = d} =- stmtCreateDomain :- sqlDefault (domainDefault d) : maybeMap sqlCheck (domainChecks d)- where- stmtCreateDomain =- newSqlStmt SqlCreateDomain obj $- "CREATE DOMAIN" <-> sqlIdCode obj <-> "AS" <-> toSqlCode (domainType d)- sqlCheck :: Check -> Maybe SqlStmt- sqlCheck c =- newSqlStmt SqlCreateCheckConstr obj $- "ALTER DOMAIN" <-> sqlIdCode obj <-> "ADD CONSTRAINT" <->- toSqlCode (checkName c) <->- "CHECK (" <>- checkCheck c <>- ")"- sqlDefault Nothing =- newSqlStmt SqlAddDefault obj $- "ALTER DOMAIN" <-> sqlIdCode obj <-> "DROP DEFAULT"- sqlDefault (Just def) =- newSqlStmt SqlAddDefault obj $- "ALTER DOMAIN" <-> sqlIdCode obj <-> "SET DEFAULT" <-> def+instance ToSqlStmts (SqlContext (Schema, Domain)) where+ toSqlStmts _ obj@(SqlContext (_, d)) =+ stmtCreateDomain :+ sqlDefault (domainDefault d) : maybeMap sqlCheck (domainChecks d)+ where+ stmtCreateDomain =+ newSqlStmt SqlCreateDomain obj $+ "CREATE DOMAIN" <-> sqlIdCode obj <-> "AS" <-> toSqlCode (domainType d)+ sqlCheck :: Check -> Maybe SqlStmt+ sqlCheck c =+ newSqlStmt SqlCreateCheckConstr obj $+ "ALTER DOMAIN" <-> sqlIdCode obj <-> "ADD CONSTRAINT" <->+ toSqlCode (checkName c) <->+ "CHECK (" <>+ checkCheck c <>+ ")"+ sqlDefault Nothing =+ newSqlStmt SqlAddDefault obj $+ "ALTER DOMAIN" <-> sqlIdCode obj <-> "DROP DEFAULT"+ sqlDefault (Just def) =+ newSqlStmt SqlAddDefault obj $+ "ALTER DOMAIN" <-> sqlIdCode obj <-> "SET DEFAULT" <-> def
src/Database/HamSql/Internal/Stmt/Drop.hs view
@@ -7,9 +7,9 @@ import Database.HamSql.Internal.Stmt.Basic -- TABLE-stmtsDropTable :: SqlIdContentSqo -> [Maybe SqlStmt]+stmtsDropTable :: SqlObj SQL_TABLE SqlName -> [Maybe SqlStmt] stmtsDropTable t = [newSqlStmt SqlDropTable t $ "DROP TABLE " <> toSqlCode t] -- TYPE-stmtsDropType :: SqlIdContentSqo -> [Maybe SqlStmt]+stmtsDropType :: SqlObj SQL_TYPE SqlName -> [Maybe SqlStmt] stmtsDropType t = [newSqlStmt SqlDropType t $ "DROP TYPE " <> toSqlCode t]
src/Database/HamSql/Internal/Stmt/Function.hs view
@@ -15,90 +15,86 @@ stmtsDropFunction' x = catMaybes [newSqlStmt SqlDropFunction x $ "DROP FUNCTION " <> toSqlCode x] -stmtsDropFunction :: SqlIdContentSqoArgtypes -> [Maybe SqlStmt]+stmtsDropFunction :: SqlObj SQL_FUNCTION (SqlName, [SqlType]) -> [Maybe SqlStmt] stmtsDropFunction x = map Just $ stmtsDropFunction' $ sqlId x -instance ToSqlStmts (SqlContextSqoArgtypes Function) where- toSqlStmts = stmtsDeployFunction--stmtsDeployFunction :: SetupContext- -> SqlContextSqoArgtypes Function- -> [Maybe SqlStmt]-stmtsDeployFunction SetupContext {setupContextSetup = setup} obj@SqlContextSqoArgtypes {sqlSqoArgtypesObject = f} =- stmtCreateFunction :- sqlSetOwner (functionOwner f) :- stmtComment : maybeMap sqlStmtGrantExecute (functionPrivExecute f)---name = schemaName m <.> functionName f- where- sqlStmtGrantExecute u = newSqlStmt SqlPriv obj $ sqlGrantExecute u- sqlGrantExecute u =- "GRANT EXECUTE ON FUNCTION \n" <> sqlIdCode obj <> "\nTO " <>- prefixedRole setup u- stmtCreateFunction =- newSqlStmt SqlCreateFunction obj $- --(maybeMap variableType (functionParameters f)) $- "CREATE OR REPLACE FUNCTION " <> sqlFunctionIdentifierDef <> "\n" <>- "RETURNS" <->- toSqlCode (functionReturns f) <>- sqlReturnsColumns (functionReturnsColumns f) <>- "\nLANGUAGE " <>- sqlLanguage (functionLanguage f) <>- "\nSECURITY " <>- sqlSecurity (functionSecurityDefiner f) <>- "\nAS\n$BODY$\n" <>- sqlBody <>- "\n$BODY$\n"- stmtComment = stmtCommentOn obj $ toSqlCodeString (functionDescription f)- sqlSetOwner (Just o) =- newSqlStmt SqlPriv obj $- "ALTER FUNCTION " <> sqlIdCode obj <> "OWNER TO " <> prefixedRole setup o- sqlSetOwner Nothing = Nothing- sqlFunctionIdentifierDef =- (toSqlCode . sqlIdNameOnly) obj <> "(\n" <>- T.intercalate ",\n" (maybeMap sqlParameterDef (functionParameters f)) <>- "\n)"- -- function parameter- sqlParameterDef p =- toSqlCode (variableName p) <-> toSqlCode (variableType p) <->- sqlParamDefault (variableDefault p)- where- sqlParamDefault Nothing = ""- sqlParamDefault (Just x) = "DEFAULT" <-> x- -- If function returns a table, use service for field definition- sqlReturnsColumns cs- | toSqlCode (functionReturns f) == "TABLE" =- " (" <\> T.intercalate ",\n" (maybeMap sqlReturnsColumn cs) <> ") "- | otherwise = ""- sqlReturnsColumn c =- toSqlCode (parameterName c) <> " " <> toSqlCode (parameterType c)- -- If language not defined, use service for variable definitions- sqlBody- | isNothing (functionLanguage f) =- "DECLARE" <\> sqlVariables (functionVariables f) <> "BEGIN" <\> body <\>- "END;"- | otherwise = body- where- body =- T.intercalate "\n" preludes <> fromMaybe "" (functionBody f) <>- T.intercalate "\n" postludes- preludes :: [Text]- preludes =- catMaybes $maybeMap functiontplBodyPrelude (functionTemplateData f)- postludes :: [Text]- postludes =- catMaybes $maybeMap functiontplBodyPostlude (functionTemplateData f)- -- Service for variable definitions- sqlVariables Nothing = ""- sqlVariables (Just vs) = T.concat (map sqlVariable vs)- sqlVariable v =- toSqlCode (variableName v) <-> toSqlCode (variableType v) <->- sqlVariableDefault (variableDefault v) <>- ";\n"- sqlVariableDefault Nothing = ""- sqlVariableDefault (Just d) = ":=" <-> d- -- SECURITY- sqlSecurity (Just True) = "DEFINER"- sqlSecurity _ = "INVOKER"- -- LANGUAGE- sqlLanguage Nothing = "plpgsql"- sqlLanguage (Just lang) = lang+instance ToSqlStmts (SqlContext (Schema, Function)) where+ toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext (s, f)) =+ stmtCreateFunction :+ sqlSetOwner (functionOwner f) :+ stmtComment : maybeMap sqlStmtGrantExecute (functionPrivExecute f)+ --name = schemaName m <.> functionName f+ where+ sqlStmtGrantExecute u = newSqlStmt SqlPriv obj $ sqlGrantExecute u+ sqlGrantExecute u =+ "GRANT EXECUTE ON FUNCTION \n" <> sqlIdCode obj <> "\nTO " <>+ prefixedRole setup u+ stmtCreateFunction =+ newSqlStmt SqlCreateFunction obj $+ --(maybeMap variableType (functionParameters f)) $+ "CREATE OR REPLACE FUNCTION " <> sqlFunctionIdentifierDef <> "\n" <>+ "RETURNS" <->+ toSqlCode (functionReturns f) <>+ sqlReturnsColumns (functionReturnsColumns f) <>+ "\nLANGUAGE " <>+ sqlLanguage (functionLanguage f) <>+ "\nSECURITY " <>+ sqlSecurity (functionSecurityDefiner f) <>+ "\nAS\n$BODY$\n" <>+ sqlBody <>+ "\n$BODY$\n"+ stmtComment = stmtCommentOn obj $ toSqlCodeString (functionDescription f)+ sqlSetOwner (Just o) =+ newSqlStmt SqlPriv obj $+ "ALTER FUNCTION " <> sqlIdCode obj <> "OWNER TO " <>+ prefixedRole setup o+ sqlSetOwner Nothing = Nothing+ sqlFunctionIdentifierDef =+ toSqlCode (schemaName s <.> functionName f) <> "(\n" <>+ T.intercalate ",\n" (maybeMap sqlParameterDef (functionParameters f)) <>+ "\n)"+ -- function parameter+ sqlParameterDef p =+ toSqlCode (variableName p) <-> toSqlCode (variableType p) <->+ sqlParamDefault (variableDefault p)+ where+ sqlParamDefault Nothing = ""+ sqlParamDefault (Just x) = "DEFAULT" <-> x+ -- If function returns a table, use service for field definition+ sqlReturnsColumns cs+ | toSqlCode (functionReturns f) == "TABLE" =+ " (" <\> T.intercalate ",\n" (maybeMap sqlReturnsColumn cs) <> ") "+ | otherwise = ""+ sqlReturnsColumn c =+ toSqlCode (parameterName c) <> " " <> toSqlCode (parameterType c)+ -- If language not defined, use service for variable definitions+ sqlBody+ | isNothing (functionLanguage f) =+ "DECLARE" <\> sqlVariables (functionVariables f) <> "BEGIN" <\> body <\>+ "END;"+ | otherwise = body+ where+ body =+ T.intercalate "\n" preludes <> fromMaybe "" (functionBody f) <>+ T.intercalate "\n" postludes+ preludes :: [Text]+ preludes =+ catMaybes $maybeMap functiontplBodyPrelude (functionTemplateData f)+ postludes :: [Text]+ postludes =+ catMaybes $maybeMap functiontplBodyPostlude (functionTemplateData f)+ -- Service for variable definitions+ sqlVariables Nothing = ""+ sqlVariables (Just vs) = T.concat (map sqlVariable vs)+ sqlVariable v =+ toSqlCode (variableName v) <-> toSqlCode (variableType v) <->+ sqlVariableDefault (variableDefault v) <>+ ";\n"+ sqlVariableDefault Nothing = ""+ sqlVariableDefault (Just d) = ":=" <-> d+ -- SECURITY+ sqlSecurity (Just True) = "DEFINER"+ sqlSecurity _ = "INVOKER"+ -- LANGUAGE+ sqlLanguage Nothing = "plpgsql"+ sqlLanguage (Just lang) = lang
src/Database/HamSql/Internal/Stmt/Role.hs view
@@ -6,16 +6,29 @@ module Database.HamSql.Internal.Stmt.Role where +import qualified Data.Text as T+ import Database.HamSql.Internal.Stmt.Basic -stmtsDropRole :: Setup -> SqlIdContentObj -> [Maybe SqlStmt]-stmtsDropRole setup role =- [ newSqlStmt SqlDropRole role $- "DROP ROLE " <> prefixedRole setup (sqlObjId role)- ]+stmtsDropRole :: Setup -> SqlObj SQL_ROLE SqlName -> [Maybe SqlStmt]+stmtsDropRole setup role@(SqlObj _ roleSqlName) =+ [newSqlStmt SqlDropRole role $ "DROP ROLE " <> prefixedRole setup roleSqlName] -instance ToSqlStmts (SqlContextObj Role) where- toSqlStmts SetupContext {setupContextSetup = setup} obj@SqlContextObj {sqlObjectObject = r} =+stmtsDropAllPrivileges :: Setup -> SqlObj SQL_ROLE SqlName -> [Maybe SqlStmt]+stmtsDropAllPrivileges setup x@(SqlObj _ n)+ | schemas == [] = [Nothing]+ | otherwise =+ [ newSqlStmt SqlRevokePrivilege x $+ "REVOKE ALL PRIVILEGES ON ALL" <-> objType <-> "IN SCHEMA" <->+ T.intercalate ", " (map toSqlCode schemas) <->+ "FROM" <->+ prefixedRole setup n+ | objType <- ["TABLES", "SEQUENCES", "FUNCTIONS"] ]+ where+ schemas = maybeMap schemaName (setupSchemaData setup)++instance ToSqlStmts (SqlContext Role) where+ toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext r) = [stmtCreateRole, stmtAlterRole, stmtCommentRole] ++ maybeMap sqlRoleMembership (roleMemberIn r) where
src/Database/HamSql/Internal/Stmt/Schema.hs view
@@ -8,8 +8,8 @@ import Database.HamSql.Internal.Stmt.Basic -instance ToSqlStmts (SqlContextObj Schema) where- toSqlStmts SetupContext {setupContextSetup = setup} obj@SqlContextObj {sqlObjectObject = s} =+instance ToSqlStmts (SqlContext Schema) where+ toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext s) = [ newSqlStmt SqlCreateSchema obj $ "CREATE SCHEMA IF NOT EXISTS" <-> sqlIdCode obj , postInst $ schemaExecPostInstall s
src/Database/HamSql/Internal/Stmt/Sequence.hs view
@@ -8,38 +8,35 @@ import Database.HamSql.Internal.Stmt.Basic -stmtsDropSequence :: SqlIdContentSqo -> [Maybe SqlStmt]+stmtsDropSequence :: SqlObj SQL_SEQUENCE SqlName -> [Maybe SqlStmt] stmtsDropSequence x = [newSqlStmt SqlDropSequence x $ "DROP SEQUENCE " <> toSqlCode x] -instance ToSqlStmts (SqlContextSqo Sequence) where- toSqlStmts = stmtsDeploySequence--stmtsDeploySequence :: SetupContext -> SqlContextSqo Sequence -> [Maybe SqlStmt]-stmtsDeploySequence _ obj@SqlContextSqo {sqlSqoObject = s} =- [ newSqlStmt SqlCreateSequence obj $ "CREATE SEQUENCE" <-> sqlIdCode obj- , newSqlStmt SqlAlterSequence obj $- "ALTER SEQUENCE" <-> sqlIdCode obj <-> incrementBy (sequenceIncrement s) <->- minValue (sequenceMinValue s) <->- maxValue (sequenceMaxValue s) <->- startValue (sequenceStartValue s) <->- cache (sequenceCache s) <->- cycled (sequenceCycle s) <->- ownedByColumn (sequenceOwnedByColumn s)- ]- where- incrementBy Nothing = "INCREMENT BY 1"- incrementBy (Just i) = "INCREMENT BY " <> tshow i- minValue Nothing = "NO MINVALUE"- minValue (Just i) = "MINVALUE " <> tshow i- maxValue Nothing = "NO MAXVALUE"- maxValue (Just i) = "MAXVALUE " <> tshow i- startValue Nothing = ""- startValue (Just i) = "START WITH " <> tshow i- cache Nothing = "CACHE 1"- cache (Just i) = "CACHE " <> tshow i- cycled Nothing = "NO CYCLE"- cycled (Just False) = "NO CYCLE"- cycled (Just True) = "CYCLE"- ownedByColumn Nothing = "OWNED BY NONE"- ownedByColumn (Just n) = "OWNED BY " <> toSqlCode n+instance ToSqlStmts (SqlContext (Schema, Sequence)) where+ toSqlStmts _ obj@(SqlContext (_, s)) =+ [ newSqlStmt SqlCreateSequence obj $ "CREATE SEQUENCE" <-> sqlIdCode obj+ , newSqlStmt SqlAlterSequence obj $+ "ALTER SEQUENCE" <-> sqlIdCode obj <-> incrementBy (sequenceIncrement s) <->+ minValue (sequenceMinValue s) <->+ maxValue (sequenceMaxValue s) <->+ startValue (sequenceStartValue s) <->+ cache (sequenceCache s) <->+ cycled (sequenceCycle s) <->+ ownedByColumn (sequenceOwnedByColumn s)+ ]+ where+ incrementBy Nothing = "INCREMENT BY 1"+ incrementBy (Just i) = "INCREMENT BY " <> tshow i+ minValue Nothing = "NO MINVALUE"+ minValue (Just i) = "MINVALUE " <> tshow i+ maxValue Nothing = "NO MAXVALUE"+ maxValue (Just i) = "MAXVALUE " <> tshow i+ startValue Nothing = ""+ startValue (Just i) = "START WITH " <> tshow i+ cache Nothing = "CACHE 1"+ cache (Just i) = "CACHE " <> tshow i+ cycled Nothing = "NO CYCLE"+ cycled (Just False) = "NO CYCLE"+ cycled (Just True) = "CYCLE"+ ownedByColumn Nothing = "OWNED BY NONE"+ ownedByColumn (Just n) = "OWNED BY " <> toSqlCode n
src/Database/HamSql/Internal/Stmt/Table.hs view
@@ -4,227 +4,221 @@ -- Some rights reserved. See COPYING, AUTHORS. {-# LANGUAGE FlexibleInstances #-} -module Database.HamSql.Internal.Stmt.Table where+module Database.HamSql.Internal.Stmt.Table+ ( 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-stmtsDropTableConstr :: SqlIdContentSqoObj -> [Maybe SqlStmt]-stmtsDropTableConstr x =+-- | Assuming that CASCADE will only cause other constraints to be deleted.+-- | Required since foreign keys may depend on other keys.+stmtsDropTableConstr :: SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName)+ -> [Maybe SqlStmt]+stmtsDropTableConstr x@(SqlObj _ (s, t, c)) = [ newSqlStmt SqlDropTableConstr x $- "ALTER TABLE" <-> sqlSqoIdCode x <-> "DROP CONSTRAINT IF EXISTS" <->- sqlSqoObjIdCode x <->+ "ALTER TABLE" <-> toSqlCode (s <.> t) <-> "DROP CONSTRAINT IF EXISTS" <->+ toSqlCode c <-> "CASCADE" ] -stmtsDropTableColumn :: SqlIdContentSqoObj -> [Maybe SqlStmt]-stmtsDropTableColumn x =+stmtsDropTableColumn :: SqlObj SQL_COLUMN (SqlName, SqlName) -> [Maybe SqlStmt]+stmtsDropTableColumn x@(SqlObj _ (t, c)) = [ newSqlStmt SqlDropTableColumn x $- "ALTER TABLE" <-> sqlSqoIdCode x <-> "DROP COLUMN" <-> sqlSqoObjIdCode x+ "ALTER TABLE" <-> toSqlCode t <-> "DROP COLUMN" <-> toSqlCode c ] -columnObj :: SqlContextSqo Table -> Column -> SqlContextSqoObj Table Column-columnObj x y =- SqlContextSqoObj- { sqlSqoObjectSchema = sqlSqoSchema x- , sqlSqoObject1 = sqlSqoObject x- , sqlSqoObject2 = y- }+constrId+ :: Schema+ -> Table+ -> SqlName+ -> SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName)+constrId s t c = SqlObj SQL_TABLE_CONSTRAINT (schemaName s, tableName t, c) -instance ToSqlStmts (SqlContextSqoObj Table Column) where- toSqlStmts _ _ = []+-- TODO: prefix with table name+stmtCheck+ :: ToSqlId a+ => a -> Check -> Maybe SqlStmt+stmtCheck obj c =+ newSqlStmt SqlCreateCheckConstr obj $+ "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>+ toSqlCode (checkName c) <>+ " CHECK (" <>+ checkCheck c <>+ ")" -instance ToSqlStmts (SqlContextSqo Table) where- toSqlStmts = stmtsDeployTable+instance ToSqlStmts (SqlContext (Schema, Table, Column)) where+ toSqlStmts context obj@(SqlContext (schema, table, rawColumn)) =+ [ stmtAddColumn+ , stmtAlterColumnType+ , stmtDropDefault+ , stmtAddColumnDefault+ , stmtAlterColumnNull+ , stmtCommentOn obj (columnDescription c)+ , stmtAddForeignKey+ , stmtColumnUnique+ ] +++ stmtsSerialSequence ++ stmtsAddColumnCheck+ -- ADD COLUMN+ where+ stmtAddColumn =+ newSqlStmt SqlAddColumn obj $+ "ALTER TABLE" <-> tblId <-> "ADD COLUMN" <-> toSqlCode (columnName c) <->+ toSqlCode (columnType c)+ -- UNIQUE+ stmtColumnUnique+ | columnUnique c == Just True =+ let constr = tableName table <> columnName c <> SqlName "key"+ in newSqlStmt SqlCreateUniqueConstr (constrId schema table constr) $+ "ALTER TABLE " <> tblId <> " ADD CONSTRAINT " <> toSqlCode constr <>+ " UNIQUE (" <>+ toSqlCode (columnName c) <>+ ")"+ | otherwise = Nothing+ -- NOT NULL+ stmtAlterColumnNull =+ stmtAlterColumn SqlAlterColumn $+ if columnNull c == Just True+ then "DROP NOT NULL"+ else "SET NOT NULL"+ -- SET DATA TYPE+ stmtAlterColumnType =+ stmtAlterColumn SqlAlterColumn $+ "SET DATA TYPE " <> toSqlCode (columnType c)+ -- DROP DEFAULT+ stmtDropDefault = stmtAlterColumn SqlDropColumnDefault "DROP DEFAULT"+ -- SET DEFAULT+ stmtAddColumnDefault = columnDefault c >>= sqlDefault+ where+ sqlDefault d = stmtAlterColumn SqlAddDefault $ "SET DEFAULT " <> d+ -- [CHECK]+ stmtsAddColumnCheck = maybeMap (stmtCheck obj) (columnChecks c)+ -- FOREIGN KEY+ stmtAddForeignKey =+ case columnReferences c of+ Nothing -> Nothing+ (Just ref) ->+ let constr = tableName table <> columnName c <> SqlName "fkey"+ in newSqlStmt+ SqlCreateForeignKeyConstr+ (constrId schema table constr) $+ "ALTER TABLE" <-> sqlIdCode obj <-> "ADD CONSTRAINT" <->+ toSqlCode constr <->+ "FOREIGN KEY (" <>+ toSqlCode (columnName c) <>+ ")" <->+ "REFERENCES" <->+ toSqlCode' (init $ expSqlName ref) <->+ "(" <>+ toSqlCode (last $ expSqlName ref) <>+ ")" <>+ maybePrefix " ON UPDATE " (columnOnRefUpdate c) <>+ maybePrefix " ON DELETE " (columnOnRefDelete c)+ -- CREATE SEQUENCE (for type SERIAL)+ stmtsSerialSequence+ | columnIsSerial = toSqlStmts context serialSequenceContext+ | otherwise = [Nothing]+ -- Helpers+ stmtAlterColumn t x =+ newSqlStmt t obj $+ "ALTER TABLE " <> tblId <> " ALTER COLUMN " <> toSqlCode (columnName c) <>+ " " <>+ x+ columnIsSerial = toSqlCode (columnType rawColumn) == "SERIAL"+ c+ | columnIsSerial =+ rawColumn+ { columnType = SqlType "integer"+ , columnDefault =+ Just $+ "nextval('" <> toSqlCode (sqlId serialSequenceContext) <> "')"+ }+ | otherwise = rawColumn+ tblId = toSqlCode $ schemaName schema <.> tableName table+ serialSequenceContext =+ SqlContext+ ( schema+ , Sequence+ -- sequenceName follows PostgreSQL internal convention+ { sequenceName = tableName table <> columnName c <> SqlName "_seq"+ , sequenceIncrement = Nothing+ , sequenceMinValue = Nothing+ , sequenceMaxValue = Nothing+ , sequenceStartValue = Nothing+ , sequenceCache = Nothing+ , sequenceCycle = Nothing+ , sequenceOwnedByColumn = Just $ SqlName $ sqlIdCode obj+ }) -stmtsDeployTable :: SetupContext -> SqlContextSqo Table -> [Maybe SqlStmt]-stmtsDeployTable context@SetupContext {setupContextSetup = setup} obj@SqlContextSqo {sqlSqoSchema = m- ,sqlSqoObject = t}- -- table with columns- =- [ stmtCreateTable- -- table comment- , stmtCommentOn obj (tableDescription t)- ] ++- map stmtAddColumn columns ++- map stmtAlterColumnType columns ++- map stmtDropDefault columns ++- map stmtAddColumnDefault columns ++- map stmtAlterColumnNull columns ++- concatMap stmtAddColumnCheck columns ++- concat (sequences (tableColumns t)) ++- maybeMap stmtCheck (tableChecks t) ++- -- column comments- map (\c -> stmtCommentOn (columnObj obj c) (columnDescription c)) columns ++- -- grant rights to roles- maybeMap (sqlGrant "SELECT") (tablePrivSelect t) ++- maybeMap (sqlGrant "UPDATE") (tablePrivUpdate t) ++- maybeMap (sqlGrant "INSERT") (tablePrivInsert t) ++- maybeMap (sqlGrant "DELETE") (tablePrivDelete t) ++- -- primary key- [sqlAddPrimaryKey (tablePrimaryKey t)] ++- -- mult column unique- maybeMap sqlUniqueConstr (tableUnique t) ++- -- single column FKs (references)- map sqlAddForeignKey columns ++- -- inheritance- maybeMap sqlAddInheritance (tableInherits t) ++- -- multi column unique constraints- map sqlColumnUnique columns ++- -- multi column FKs- maybeMap sqlAddForeignKey' (tableForeignKeys t)- where- stmtCreateTable =- newSqlStmt SqlCreateTable obj $- "CREATE TABLE IF NOT EXISTS" <-> sqlIdCode obj <> " ()"- stmtCheck c =- newSqlStmt SqlCreateCheckConstr obj $- "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>- constrName (checkName c) <>- " CHECK (" <>- checkCheck c <>- ")"- -- COLUMNS- sqlAlterColumn c =- "ALTER TABLE " <> sqlIdCode obj <> " ALTER COLUMN " <>- toSqlCode (columnName c) <>- " "- stmtAddColumn c =- newSqlStmt SqlAddColumn (columnObj obj c) $- "ALTER TABLE" <-> sqlIdCode obj <-> "ADD COLUMN" <->- toSqlCode (columnName c) <->- toSqlCode (columnType c)- stmtAlterColumnType c =- newSqlStmt SqlAlterColumn obj $- sqlAlterColumn c <> "SET DATA TYPE " <> toSqlCode (columnType c)- stmtDropDefault c =- newSqlStmt SqlDropColumnDefault obj $ sqlAlterColumn c <> "DROP DEFAULT"- stmtAddColumnCheck c = maybeMap stmtCheck (columnChecks c)- stmtAlterColumnNull c =- newSqlStmt SqlAlterColumn obj $- sqlAlterColumn c <> sqlSetNull (columnNull c)- where- sqlSetNull Nothing = sqlSetNull (Just False)- sqlSetNull (Just False) = "SET NOT NULL"- sqlSetNull (Just True) = "DROP NOT NULL"- stmtAddColumnDefault c = columnDefault c >>= sqlDefault- where- sqlDefault d =- newSqlStmt SqlAddDefault (columnObj obj c) $- sqlAlterColumn c <> "SET DEFAULT " <> d- -- SERIAL- columns = map injectSerialParameters (tableColumns t)- injectSerialParameters c- | columnIsSerial c =- c- { columnType = SqlType "integer"- , columnDefault =- Just $ "nextval('" <> sqlIdCode (serialSqlContext c) <> "')"- }- | otherwise = c- columnIsSerial c = toSqlCode (columnType c) == "SERIAL"- -- do not change this, it is PostgreSQL internal convention- serialSequenceName c =- tableName t // SqlName "_" // columnName c // SqlName "_seq"- sequences cs = map serial (filter columnIsSerial cs)- where- serial c = stmtsDeploySequence context (serialSqlContext c)- serialSqlContext c =- SqlContextSqo- { sqlSqoSchema = m- , sqlSqoObject =- Sequence- { sequenceName = serialSequenceName c- , sequenceIncrement = Nothing- , sequenceMinValue = Nothing- , sequenceMaxValue = Nothing- , sequenceStartValue = Nothing- , sequenceCache = Nothing- , sequenceCycle = Nothing- , sequenceOwnedByColumn = Just $ SqlName $ sqlIdCode (columnObj obj c)- }- }- -- PRIMARY KEY- sqlAddPrimaryKey :: [SqlName] -> Maybe SqlStmt- sqlAddPrimaryKey [] = Nothing- sqlAddPrimaryKey ks =- newSqlStmt SqlCreatePrimaryKeyConstr (constrId (SqlName "primary_key")) $- "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>- constrName (SqlName "primary_key") <>- " PRIMARY KEY (" <>- T.intercalate ", " (map toSqlCode ks) <>- ")"- sqlUniqueConstr :: UniqueKey -> Maybe SqlStmt- sqlUniqueConstr ks =- newSqlStmt SqlCreateUniqueConstr (constrId (uniquekeyName ks)) $- "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>- constrName (uniquekeyName ks) <>- " UNIQUE (" <>- T.intercalate ", " (map toSqlCode (uniquekeyColumns ks)) <>- ")"- --sqlCheck c =- -- " CONSTRAINT " <> name (checkName c) <> " CHECK (" <> checkCheck c <> ")"- sqlAddForeignKey :: Column -> Maybe SqlStmt- sqlAddForeignKey Column {columnReferences = Nothing} = Nothing- sqlAddForeignKey c@Column {columnReferences = (Just ref)} =- newSqlStmt SqlCreateForeignKeyConstr (constrId (columnName c)) $- "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>- constrName (columnName c) <>- " FOREIGN KEY (" <>- toSqlCode (columnName c) <>- ")" <>- " REFERENCES " <>- toSqlCode' (init $ expSqlName ref) <>- " (" <>- toSqlCode (last $ expSqlName ref) <>- ")" <>- sqlOnRefUpdate (columnOnRefUpdate c) <>- sqlOnRefDelete (columnOnRefDelete c)- sqlAddForeignKey' :: ForeignKey -> Maybe SqlStmt- sqlAddForeignKey' fk =- newSqlStmt SqlCreateForeignKeyConstr (constrId (foreignkeyName fk)) $- "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>- constrName (foreignkeyName fk) <>- " FOREIGN KEY (" <>- T.intercalate ", " (map toSqlCode (foreignkeyColumns fk)) <>- ")" <>- " REFERENCES " <>- toSqlCode (foreignkeyRefTable fk) <>- " (" <>- T.intercalate ", " (map toSqlCode $ foreignkeyRefColumns fk) <>- ")" <>- sqlOnRefUpdate (foreignkeyOnUpdate fk) <>- sqlOnRefDelete (foreignkeyOnDelete fk)- sqlOnRefUpdate Nothing = ""- sqlOnRefUpdate (Just a) = " ON UPDATE " <> a- sqlOnRefDelete Nothing = ""- sqlOnRefDelete (Just a) = " ON DELETE " <> a- sqlGrant right role =- newSqlStmt- SqlPriv- obj- ("GRANT " <> right <> " ON TABLE " <> toSqlCode (tableName t) <> " TO " <>- prefixedRole setup role)- sqlAddInheritance :: SqlName -> Maybe SqlStmt- sqlAddInheritance n =- newSqlStmt SqlAlterTable obj $- "ALTER TABLE " <> sqlIdCode obj <> " INHERIT " <> toSqlCode n- sqlColumnUnique c@Column {columnUnique = (Just True)} =- newSqlStmt SqlCreateUniqueConstr (constrId (columnName c)) $- "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>- constrName (columnName c) <>- " UNIQUE (" <>- toSqlCode (columnName c) <>- ")"- sqlColumnUnique _ = Nothing- -- tools- constrName a = toSqlCode (tableName t // SqlName "-" // a)- constrId a =- SqlIdContentSqoObj- "TABLE-CONSTRAINT"- (SqlName $ sqlIdCode obj)- (SqlName $ constrName a)+instance ToSqlStmts (SqlContext (Schema, Table)) where+ toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext (s, t)) =+ [ stmtCreateTable+ -- table comment+ , stmtCommentOn obj (tableDescription t)+ ] +++ maybeMap (stmtCheck obj) (tableChecks t) +++ -- grant rights to roles+ maybeMap (sqlGrant "SELECT") (tablePrivSelect t) +++ maybeMap (sqlGrant "UPDATE") (tablePrivUpdate t) +++ maybeMap (sqlGrant "INSERT") (tablePrivInsert t) +++ maybeMap (sqlGrant "DELETE") (tablePrivDelete t) +++ -- primary key+ [sqlAddPrimaryKey (tablePrimaryKey t)] +++ -- mult column unique+ maybeMap sqlUniqueConstr (tableUnique t) +++ -- inheritance+ maybeMap sqlAddInheritance (tableInherits t) +++ -- multi column FKs+ maybeMap sqlAddForeignKey' (tableForeignKeys t)+ where+ stmtCreateTable =+ newSqlStmt SqlCreateTable obj $+ "CREATE TABLE IF NOT EXISTS" <-> sqlIdCode obj <> " ()"+ -- PRIMARY KEY+ sqlAddPrimaryKey :: [SqlName] -> Maybe SqlStmt+ sqlAddPrimaryKey [] = Nothing+ sqlAddPrimaryKey ks =+ let constr = tableName t <> SqlName "pkey"+ in newSqlStmt SqlCreatePrimaryKeyConstr (constrId s t constr) $+ "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> toSqlCode constr <>+ " PRIMARY KEY (" <>+ T.intercalate ", " (map toSqlCode ks) <>+ ")"+ -- TODO: allow empty name with "mconcat (uniquekeyColumns ks)"+ sqlUniqueConstr :: UniqueKey -> Maybe SqlStmt+ sqlUniqueConstr ks =+ let constr = tableName t <> uniquekeyName ks+ in newSqlStmt SqlCreateUniqueConstr (constrId s t constr) $+ "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> toSqlCode constr <>+ " UNIQUE (" <>+ T.intercalate ", " (map toSqlCode (uniquekeyColumns ks)) <>+ ")"+ sqlAddForeignKey' :: ForeignKey -> Maybe SqlStmt+ sqlAddForeignKey' fk =+ let constr = tableName t <> foreignkeyName fk+ in newSqlStmt SqlCreateForeignKeyConstr (constrId s t constr) $+ "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> toSqlCode constr <>+ " FOREIGN KEY (" <>+ T.intercalate ", " (map toSqlCode (foreignkeyColumns fk)) <>+ ")" <>+ " REFERENCES " <>+ toSqlCode (foreignkeyRefTable fk) <>+ " (" <>+ T.intercalate ", " (map toSqlCode $ foreignkeyRefColumns fk) <>+ ")" <>+ maybePrefix " ON UPDATE " (foreignkeyOnUpdate fk) <>+ maybePrefix " ON DELETE " (foreignkeyOnDelete fk)+ sqlGrant right role =+ newSqlStmt+ SqlPriv+ obj+ ("GRANT " <> right <> " ON TABLE " <> toSqlCode (tableName t) <>+ " TO " <>+ prefixedRole setup role)+ sqlAddInheritance :: SqlName -> Maybe SqlStmt+ sqlAddInheritance n =+ newSqlStmt SqlAlterTable obj $+ "ALTER TABLE " <> sqlIdCode obj <> " INHERIT " <> toSqlCode n
src/Database/HamSql/Internal/Stmt/Type.hs view
@@ -10,18 +10,15 @@ import Database.HamSql.Internal.Stmt.Basic -instance ToSqlStmts (SqlContextSqo Type) where- toSqlStmts = stmtsDeployType--stmtsDeployType :: SetupContext -> SqlContextSqo Type -> [Maybe SqlStmt]-stmtsDeployType _ obj@SqlContextSqo {sqlSqoObject = t} =- [ newSqlStmt SqlCreateType obj $- "CREATE TYPE" <-> sqlIdCode obj <-> "AS (" <>- T.intercalate ", " (map sqlElement (typeElements t)) <>- ")"- , stmtCommentOn obj (typeDescription t)- ]--- ALTER TYPE name ALTER ATTRIBUTE attribute_name [ SET DATA ] TYPE data_type- where- sqlElement e =- toSqlCode (typeelementName e) <-> toSqlCode (typeelementType e)+instance ToSqlStmts (SqlContext (Schema, Type)) where+ toSqlStmts _ obj@(SqlContext (_, t)) =+ [ newSqlStmt SqlCreateType obj $+ "CREATE TYPE" <-> sqlIdCode obj <-> "AS (" <>+ T.intercalate ", " (map sqlElement (typeElements t)) <>+ ")"+ , stmtCommentOn obj (typeDescription t)+ ]+ -- ALTER TYPE name ALTER ATTRIBUTE attribute_name [ SET DATA ] TYPE data_type+ where+ sqlElement e =+ toSqlCode (typeelementName e) <-> toSqlCode (typeelementType e)
src/Database/HamSql/Internal/Utils.hs view
@@ -63,13 +63,17 @@ removeDuplicates = map head . group . sort --- Maybe Utils+maybeMap :: (a -> b) -> Maybe [a] -> [b]+maybeMap f = maybe [] (map f)++maybePrefix :: Text -> Maybe Text -> Text+maybePrefix _ Nothing = ""+maybePrefix p (Just x) = p <> x+ -- | Joins two Maybe lists maybeJoin :: Maybe [a] -> Maybe [a] -> Maybe [a] maybeJoin Nothing Nothing = Nothing maybeJoin xs ys = Just (fromMaybe [] xs ++ fromMaybe [] ys)--maybeMap :: (a -> b) -> Maybe [a] -> [b]-maybeMap f = maybe [] (map f) -- | Takes the right value, if Just there maybeRight :: Maybe a -> Maybe a -> Maybe a
src/Database/YamSql.hs view
@@ -3,11 +3,11 @@ -- Copyright 2016 by it's authors. -- Some rights reserved. See COPYING, AUTHORS. module Database.YamSql- ( module Database.YamSql.Internal.Schema+ ( module Database.YamSql.Internal.Obj.Schema , module Database.YamSql.Internal.SqlId , module Database.YamSql.Internal.Commons ) where import Database.YamSql.Internal.Commons-import Database.YamSql.Internal.Schema+import Database.YamSql.Internal.Obj.Schema import Database.YamSql.Internal.SqlId
− src/Database/YamSql/Internal/Check.hs
@@ -1,27 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Check where--import Database.YamSql.Internal.Basic--data Check = Check- { checkName :: SqlName- , checkDescription :: Text- , checkCheck :: Text- } deriving (Generic, Show, Data)--instance FromJSON Check where- parseJSON = parseYamSql--instance ToJSON Check where- toJSON = toYamSqlJson---- TODO clearify if this is useful for uniqueness-instance ToSqlIdPart Check where- sqlIdPart = checkName- sqlIdPartType = const "CHECK"
− src/Database/YamSql/Internal/Domain.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Domain where--import Database.YamSql.Internal.Basic-import Database.YamSql.Internal.Check---- | Domains are aliases of an existing SQL types, possibly with checks-data Domain = Domain- { domainName :: SqlName- , domainDescription :: Text- , domainType :: SqlType- , domainDefault :: Maybe Text- , domainChecks :: Maybe [Check]- } deriving (Generic, Show, Data)--instance FromJSON Domain where- parseJSON = parseYamSql--instance ToJSON Domain where- toJSON = toYamSqlJson--instance ToSqlIdPart Domain where- sqlIdPart = domainName- sqlIdPartType = const "DOMAIN"
− src/Database/YamSql/Internal/Function.hs
@@ -1,110 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Function where--import Database.YamSql.Internal.Basic-import Database.YamSql.Internal.Commons--data Function = Function- -- function name- { functionName :: SqlName- -- | description what the function is good for- , functionDescription :: Text- -- | return type of the function, TABLE is special (see return_columns)- , functionReturns :: SqlType- -- | parameters the function takes- , functionParameters :: Maybe [Variable]- -- | list of templates, used for this function- , functionTemplates :: Maybe [SqlName]- -- | loaded templates, not designed for use via Yaml- --- -- __TODO: move to xfunctionInternal__- , functionTemplateData :: Maybe [FunctionTpl]- -- | if return is TABLE, gives the columns that are returned (see parameter)- , functionReturnsColumns :: Maybe [Parameter]- -- | variables that are defined (ignored if language is given)- , functionVariables :: Maybe [Variable]- -- | Role that has the privilege to execute the function- , functionPrivExecute :: Maybe [SqlName]- -- | If true, the function is executed with the privileges of the owner!- -- | Owner has to be given, if this is true (not implemented yet!)- , functionSecurityDefiner :: Maybe Bool- -- | owner of the function- , functionOwner :: Maybe SqlName- -- | language in which the body is written- -- if not defined, pgsql is assumed an variables must be defined via variables- -- if pgsql is given explicitly, variables are your problem...- , functionLanguage :: Maybe Text- -- | the code of the function (body)- , functionBody :: Maybe Text- } deriving (Generic, Show, Data)--instance FromJSON Function where- parseJSON = parseYamSql--instance ToJSON Function where- toJSON = toYamSqlJson--instance ToSqlIdPart Function where- sqlIdPart = functionName- sqlIdPartType = const "FUNCTION"--instance ToSqlIdPartArgs Function where- sqlIdPartArgs x = maybeMap variableType $ functionParameters x--data FunctionTpl = FunctionTpl- -- template name, used to refere the template via templates- { functiontplTemplate :: SqlName- -- description what the template is good for- , functiontplDescription :: Text- -- language of the function has to be the same as for used templates- -- TODO: implement checks to avoid explosions here ;)- , functiontplLanguage :: Maybe Text- -- parameters are joined with function definition parameters- , functiontplParameters :: Maybe [Variable]- -- variables are appended to the functions variables- , functiontplVariables :: Maybe [Variable]- -- defines priv_execute, can be overwritten by function definition- , functiontplPrivExecute :: Maybe [SqlName]- -- defines security_definer, can be overwritten by function definition- , functiontplSecurityDefiner :: Maybe Bool- -- defines owner, can be overwritten by function definition- , functiontplOwner :: Maybe SqlName- -- code added before the body of the function- , functiontplBodyPrelude :: Maybe Text- -- code added after the body of the function- , functiontplBodyPostlude :: Maybe Text- } deriving (Generic, Show, Data)--instance FromJSON FunctionTpl where- parseJSON = parseYamSql--instance ToJSON FunctionTpl where- toJSON = toYamSqlJson--applyFunctionTpl :: FunctionTpl -> Function -> Function-applyFunctionTpl t f =- f- { functionPrivExecute =- maybeRight (functiontplPrivExecute t) (functionPrivExecute f)- , functionSecurityDefiner =- maybeRight (functiontplSecurityDefiner t) (functionSecurityDefiner f)- , functionOwner = maybeRight (functiontplOwner t) (functionOwner f)- , functionParameters =- maybeJoin (functionParameters f) (functiontplParameters t)- , functionVariables = maybeJoin (functionVariables f) (functiontplVariables t)- , functionBody =- Just $- maybeStringL (functiontplBodyPrelude t) <> fromMaybe "" (functionBody f) <>- maybeStringR (functiontplBodyPostlude t)- }- where- maybeStringL (Just xs) = xs <> "\n"- maybeStringL Nothing = ""- maybeStringR (Just xs) = "\n" <> xs- maybeStringR Nothing = ""
+ src/Database/YamSql/Internal/Obj/Check.hs view
@@ -0,0 +1,19 @@+-- This file is part of HamSql+--+-- Copyright 2014-2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+module Database.YamSql.Internal.Obj.Check where++import Database.YamSql.Internal.Basic++data Check = Check+ { checkName :: SqlName+ , checkDescription :: Text+ , checkCheck :: Text+ } deriving (Generic, Show, Data)++instance FromJSON Check where+ parseJSON = parseYamSql++instance ToJSON Check where+ toJSON = toYamSqlJson
+ src/Database/YamSql/Internal/Obj/Domain.hs view
@@ -0,0 +1,33 @@+module Database.YamSql.Internal.Obj.Domain where++import Database.YamSql.Internal.Basic+import Database.YamSql.Internal.Obj.Check++-- | Domains are aliases of an existing SQL types, possibly with checks+data Domain = Domain+ { domainName :: SqlName+ , domainDescription :: Text+ , domainType :: SqlType+ , domainDefault :: Maybe Text+ , domainChecks :: Maybe [Check]+ } deriving (Generic, Show, Data)++instance FromJSON Domain where+ parseJSON = parseYamSql++instance ToJSON Domain where+ toJSON = toYamSqlJson++data SQL_DOMAIN =+ SQL_DOMAIN+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_DOMAIN where+ toSqlCode = const "DOMAIN"++data SQL_DOMAIN_CONSTRAINT =+ SQL_DOMAIN_CONSTRAINT+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_DOMAIN_CONSTRAINT where+ toSqlCode = const "DOMAIN_CONSTRAINT"
+ src/Database/YamSql/Internal/Obj/Function.hs view
@@ -0,0 +1,107 @@+-- This file is part of HamSql+--+-- Copyright 2014-2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+module Database.YamSql.Internal.Obj.Function where++import Database.YamSql.Internal.Basic+import Database.YamSql.Internal.Commons++data Function = Function+ -- function name+ { functionName :: SqlName+ -- | description what the function is good for+ , functionDescription :: Text+ -- | return type of the function, TABLE is special (see return_columns)+ , functionReturns :: SqlType+ -- | parameters the function takes+ , functionParameters :: Maybe [Variable]+ -- | list of templates, used for this function+ , functionTemplates :: Maybe [SqlName]+ -- | loaded templates, not designed for use via Yaml+ --+ -- __TODO: move to xfunctionInternal__+ , functionTemplateData :: Maybe [FunctionTpl]+ -- | if return is TABLE, gives the columns that are returned (see parameter)+ , functionReturnsColumns :: Maybe [Parameter]+ -- | variables that are defined (ignored if language is given)+ , functionVariables :: Maybe [Variable]+ -- | Role that has the privilege to execute the function+ , functionPrivExecute :: Maybe [SqlName]+ -- | If true, the function is executed with the privileges of the owner!+ -- | Owner has to be given, if this is true (not implemented yet!)+ , functionSecurityDefiner :: Maybe Bool+ -- | owner of the function+ , functionOwner :: Maybe SqlName+ -- | language in which the body is written+ -- if not defined, pgsql is assumed an variables must be defined via variables+ -- if pgsql is given explicitly, variables are your problem...+ , functionLanguage :: Maybe Text+ -- | the code of the function (body)+ , functionBody :: Maybe Text+ } deriving (Generic, Show, Data)++instance FromJSON Function where+ parseJSON = parseYamSql++instance ToJSON Function where+ toJSON = toYamSqlJson++data SQL_FUNCTION =+ SQL_FUNCTION+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_FUNCTION where+ toSqlCode = const "FUNCTION"++data FunctionTpl = FunctionTpl+ -- template name, used to refere the template via templates+ { functiontplTemplate :: SqlName+ -- description what the template is good for+ , functiontplDescription :: Text+ -- language of the function has to be the same as for used templates+ -- TODO: implement checks to avoid explosions here ;)+ , functiontplLanguage :: Maybe Text+ -- parameters are joined with function definition parameters+ , functiontplParameters :: Maybe [Variable]+ -- variables are appended to the functions variables+ , functiontplVariables :: Maybe [Variable]+ -- defines priv_execute, can be overwritten by function definition+ , functiontplPrivExecute :: Maybe [SqlName]+ -- defines security_definer, can be overwritten by function definition+ , functiontplSecurityDefiner :: Maybe Bool+ -- defines owner, can be overwritten by function definition+ , functiontplOwner :: Maybe SqlName+ -- code added before the body of the function+ , functiontplBodyPrelude :: Maybe Text+ -- code added after the body of the function+ , functiontplBodyPostlude :: Maybe Text+ } deriving (Generic, Show, Data)++instance FromJSON FunctionTpl where+ parseJSON = parseYamSql++instance ToJSON FunctionTpl where+ toJSON = toYamSqlJson++applyFunctionTpl :: FunctionTpl -> Function -> Function+applyFunctionTpl t f =+ f+ { functionPrivExecute =+ maybeRight (functiontplPrivExecute t) (functionPrivExecute f)+ , functionSecurityDefiner =+ maybeRight (functiontplSecurityDefiner t) (functionSecurityDefiner f)+ , functionOwner = maybeRight (functiontplOwner t) (functionOwner f)+ , functionParameters =+ maybeJoin (functionParameters f) (functiontplParameters t)+ , functionVariables = maybeJoin (functionVariables f) (functiontplVariables t)+ , functionBody =+ Just $+ maybeStringL (functiontplBodyPrelude t) <> fromMaybe "" (functionBody f) <>+ maybeStringR (functiontplBodyPostlude t)+ }+ where+ maybeStringL (Just xs) = xs <> "\n"+ maybeStringL Nothing = ""+ maybeStringR (Just xs) = "\n" <> xs+ maybeStringR Nothing = ""
+ src/Database/YamSql/Internal/Obj/Role.hs view
@@ -0,0 +1,31 @@+-- This file is part of HamSql+--+-- Copyright 2014-2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+module Database.YamSql.Internal.Obj.Role where++import Database.YamSql.Internal.Basic++data Role = Role+ { roleName :: SqlName+ , roleDescription :: Text+ , roleLogin :: Maybe Bool+ , rolePassword :: Maybe Text+ , roleMemberIn :: Maybe [SqlName]+ } deriving (Generic, Show, Data)++instance FromJSON Role where+ parseJSON = parseYamSql++instance ToJSON Role where+ toJSON = toYamSqlJson++data SQL_ROLE =+ SQL_ROLE+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_ROLE where+ toSqlCode = const "ROLE"++instance ToSqlId (SqlContext Role) where+ sqlId (SqlContext x) = SqlId $ SqlObj SQL_ROLE (roleName x)
+ src/Database/YamSql/Internal/Obj/Schema.hs view
@@ -0,0 +1,97 @@+-- This file is part of HamSql+--+-- Copyright 2014-2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+{-# LANGUAGE GADTs #-}++module Database.YamSql.Internal.Obj.Schema+ ( Schema(..)+ , module Database.YamSql.Internal.Obj.Check+ , module Database.YamSql.Internal.Obj.Domain+ , module Database.YamSql.Internal.Obj.Function+ , module Database.YamSql.Internal.Obj.Role+ , module Database.YamSql.Internal.Obj.Sequence+ , module Database.YamSql.Internal.Obj.Table+ , module Database.YamSql.Internal.Obj.Type+ ) where++import Database.YamSql.Internal.Basic+import Database.YamSql.Internal.Commons+import Database.YamSql.Internal.Obj.Check+import Database.YamSql.Internal.Obj.Domain+import Database.YamSql.Internal.Obj.Function+import Database.YamSql.Internal.Obj.Role+import Database.YamSql.Internal.Obj.Sequence+import Database.YamSql.Internal.Obj.Table+import Database.YamSql.Internal.Obj.Type++-- Schema --+data Schema = Schema+ { schemaName :: SqlName+ , schemaDescription :: Text+ , schemaDependencies :: Maybe [SqlName]+ , schemaFunctions :: Maybe [Function]+ , schemaFunctionTemplates :: Maybe [FunctionTpl]+ , schemaTables :: Maybe [Table]+ , schemaTableTemplates :: Maybe [TableTpl]+ , schemaRoles :: Maybe [Role]+ , schemaSequences :: Maybe [Sequence]+ , schemaPrivUsage :: Maybe [SqlName]+ , schemaPrivSelectAll :: Maybe [SqlName]+ , schemaPrivInsertAll :: Maybe [SqlName]+ , schemaPrivUpdateAll :: Maybe [SqlName]+ , schemaPrivDeleteAll :: Maybe [SqlName]+ , schemaPrivSequenceAll :: Maybe [SqlName]+ , schemaPrivExecuteAll :: Maybe [SqlName]+ , schemaPrivAllAll :: Maybe [SqlName]+ , schemaDomains :: Maybe [Domain]+ , schemaTypes :: Maybe [Type]+ , schemaExecPostInstall :: Maybe Text+ -- TODO: rename to execPostAll+ , schemaExecPostInstallAndUpgrade :: Maybe Text+ } deriving (Generic, Show, Data)++instance FromJSON Schema where+ parseJSON = parseYamSql++instance ToJSON Schema where+ toJSON = toYamSqlJson++data SQL_SCHEMA =+ SQL_SCHEMA+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_SCHEMA where+ toSqlCode = const "SCHEMA"++instance ToSqlId (SqlContext Schema) where+ sqlId (SqlContext s) = SqlId $ SqlObj SQL_SCHEMA (schemaName s)++-- Other stuff+instance ToSqlId (SqlContext (Schema, Table)) where+ sqlId (SqlContext (s, x)) =+ SqlId $ SqlObj SQL_TABLE (schemaName s <.> tableName x)++instance ToSqlId (SqlContext (Schema, Table, Column)) where+ sqlId (SqlContext (s, x, y)) =+ SqlId $ SqlObj SQL_COLUMN (schemaName s <.> tableName x, columnName y)++instance ToSqlId (SqlContext (Schema, Domain)) where+ sqlId (SqlContext (s, x)) =+ SqlId $ SqlObj SQL_DOMAIN (schemaName s <.> domainName x)++instance ToSqlId (SqlContext (Schema, Function)) where+ sqlId (SqlContext (s, x)) =+ SqlId $+ SqlObj+ SQL_FUNCTION+ ( schemaName s <.> functionName x+ , maybeMap variableType $ functionParameters x)++instance ToSqlId (SqlContext (Schema, Sequence)) where+ sqlId (SqlContext (s, x)) =+ SqlId $ SqlObj SQL_SEQUENCE (schemaName s <.> sequenceName x)++instance ToSqlId (SqlContext (Schema, Type)) where+ sqlId (SqlContext (s, x)) =+ SqlId $ SqlObj SQL_TYPE (schemaName s <.> typeName x)
+ src/Database/YamSql/Internal/Obj/Sequence.hs view
@@ -0,0 +1,28 @@+module Database.YamSql.Internal.Obj.Sequence where++import Database.YamSql.Internal.Basic++data Sequence = Sequence+ { sequenceName :: SqlName+ , sequenceIncrement :: Maybe Int+ , sequenceMinValue :: Maybe Int+ , sequenceMaxValue :: Maybe Int+ , sequenceStartValue :: Maybe Int+ , sequenceCache :: Maybe Int+ , sequenceCycle :: Maybe Bool+ -- PostgreSQL extension+ , sequenceOwnedByColumn :: Maybe SqlName+ } deriving (Generic, Show, Data)++instance FromJSON Sequence where+ parseJSON = parseYamSql++instance ToJSON Sequence where+ toJSON = toYamSqlJson++data SQL_SEQUENCE =+ SQL_SEQUENCE+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_SEQUENCE where+ toSqlCode = const "SEQUENCE"
+ src/Database/YamSql/Internal/Obj/Table.hs view
@@ -0,0 +1,125 @@+module Database.YamSql.Internal.Obj.Table where++import Database.YamSql.Internal.Basic+import Database.YamSql.Internal.Obj.Check++data Table = Table+ { tableName :: SqlName+ , tableDescription :: Text+ , tableColumns :: [Column]+ , tablePrimaryKey :: [SqlName]+ , tableUnique :: Maybe [UniqueKey]+ , tableForeignKeys :: Maybe [ForeignKey]+ , tableChecks :: Maybe [Check]+ , tableInherits :: Maybe [SqlName]+ , tablePrivSelect :: Maybe [SqlName]+ , tablePrivInsert :: Maybe [SqlName]+ , tablePrivUpdate :: Maybe [SqlName]+ , tablePrivDelete :: Maybe [SqlName]+ , tableTemplates :: Maybe [SqlName]+ , tableTemplateData :: Maybe [TableTpl]+ } deriving (Data, Generic, Show)++instance FromJSON Table where+ parseJSON = parseYamSql++instance ToJSON Table where+ toJSON = toYamSqlJson++data SQL_TABLE =+ SQL_TABLE+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_TABLE where+ toSqlCode = const "TABLE"++data TableTpl = TableTpl+ { tabletplTemplate :: SqlName+ , tabletplDescription :: Text+ , tabletplForeignKeys :: Maybe [ForeignKey]+ , tabletplInherits :: Maybe [SqlName]+ , tabletplColumns :: Maybe [Column]+ , tabletplChecks :: Maybe [Check]+ , tabletplPrivSelect :: Maybe [SqlName]+ , tabletplPrivInsert :: Maybe [SqlName]+ , tabletplPrivUpdate :: Maybe [SqlName]+ , tabletplPrivDelete :: Maybe [SqlName]+ } deriving (Generic, Show, Data)++instance FromJSON TableTpl where+ parseJSON = parseYamSql++instance ToJSON TableTpl where+ toJSON = toYamSqlJson++data Column = Column+ { columnName :: SqlName+ , columnType :: SqlType+ , columnDescription :: Text+ , columnDefault :: Maybe Text+ , columnNull :: Maybe Bool+ , columnReferences :: Maybe SqlName+ , columnOnRefDelete :: Maybe Text+ , columnOnRefUpdate :: Maybe Text+ , columnUnique :: Maybe Bool+ , columnChecks :: Maybe [Check]+ } deriving (Generic, Show, Data)++instance FromJSON Column where+ parseJSON = parseYamSql++instance ToJSON Column where+ toJSON = toYamSqlJson++data SQL_COLUMN =+ SQL_COLUMN+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_COLUMN where+ toSqlCode = const "COLUMN"++applyTableTpl :: TableTpl -> Table -> Table+applyTableTpl tpl t =+ t+ { tableColumns = fromMaybe [] (tabletplColumns tpl) ++ tableColumns t+ , tableForeignKeys = maybeJoin (tabletplForeignKeys tpl) (tableForeignKeys t)+ , tableInherits = maybeJoin (tabletplInherits tpl) (tableInherits t)+ , tableChecks = maybeJoin (tabletplChecks tpl) (tableChecks t)+ , tablePrivSelect = maybeJoin (tabletplPrivSelect tpl) (tablePrivSelect t)+ , tablePrivInsert = maybeJoin (tabletplPrivInsert tpl) (tablePrivInsert t)+ , tablePrivUpdate = maybeJoin (tabletplPrivUpdate tpl) (tablePrivUpdate t)+ , tablePrivDelete = maybeJoin (tabletplPrivDelete tpl) (tablePrivDelete t)+ }++data UniqueKey = UniqueKey+ { uniquekeyName :: SqlName+ , uniquekeyColumns :: [SqlName]+ } deriving (Generic, Show, Data)++instance FromJSON UniqueKey where+ parseJSON = parseYamSql++instance ToJSON UniqueKey where+ toJSON = toYamSqlJson++data ForeignKey = ForeignKey+ { foreignkeyName :: SqlName+ , foreignkeyColumns :: [SqlName]+ , foreignkeyRefTable :: SqlName+ , foreignkeyRefColumns :: [SqlName]+ , foreignkeyOnDelete :: Maybe Text+ , foreignkeyOnUpdate :: Maybe Text+ } deriving (Generic, Show, Data)++instance FromJSON ForeignKey where+ parseJSON = parseYamSql++instance ToJSON ForeignKey where+ toJSON = toYamSqlJson++data SQL_TABLE_CONSTRAINT =+ SQL_TABLE_CONSTRAINT+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_TABLE_CONSTRAINT where+ toSqlCode = const "COLUMN"
+ src/Database/YamSql/Internal/Obj/Type.hs view
@@ -0,0 +1,40 @@+-- This file is part of HamSql+--+-- Copyright 2014-2016 by it's authors.+-- Some rights reserved. See COPYING, AUTHORS.+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Database.YamSql.Internal.Obj.Type where++import Database.YamSql.Internal.Basic++data Type = Type+ { typeName :: SqlName+ , typeDescription :: Text+ , typeElements :: [TypeElement]+ } deriving (Generic, Show, Data)++instance FromJSON Type where+ parseJSON = parseYamSql++instance ToJSON Type where+ toJSON = toYamSqlJson++data TypeElement = TypeElement+ { typeelementName :: SqlName+ , typeelementType :: SqlType+ } deriving (Generic, Show, Data)++instance FromJSON TypeElement where+ parseJSON = parseYamSql++instance ToJSON TypeElement where+ toJSON = toYamSqlJson++data SQL_TYPE =+ SQL_TYPE+ deriving (SqlObjType, Show)++instance ToSqlCode SQL_TYPE where+ toSqlCode = const "TYPE"
− src/Database/YamSql/Internal/Role.hs
@@ -1,28 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Role where--import Database.YamSql.Internal.Basic--data Role = Role- { roleName :: SqlName- , roleDescription :: Text- , roleLogin :: Maybe Bool- , rolePassword :: Maybe Text- , roleMemberIn :: Maybe [SqlName]- } deriving (Generic, Show, Data)--instance FromJSON Role where- parseJSON = parseYamSql--instance ToJSON Role where- toJSON = toYamSqlJson--instance ToSqlIdPart Role where- sqlIdPart = roleName- sqlIdPartType = const "ROLE"
− src/Database/YamSql/Internal/Schema.hs
@@ -1,123 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneDeriving #-}--module Database.YamSql.Internal.Schema- ( Schema(..)- , SqlContextObj(..)- , SqlContextSqoArgtypes(..)- , SqlContextSqo(..)- , SqlContextSqoObj(..)- , sqlIdNameOnly- , module Database.YamSql.Internal.Check- , module Database.YamSql.Internal.Domain- , module Database.YamSql.Internal.Function- , module Database.YamSql.Internal.Role- , module Database.YamSql.Internal.Sequence- , module Database.YamSql.Internal.Table- , module Database.YamSql.Internal.Type- ) where--import Database.YamSql.Internal.Basic--import Database.YamSql.Internal.Check-import Database.YamSql.Internal.Domain-import Database.YamSql.Internal.Function-import Database.YamSql.Internal.Role-import Database.YamSql.Internal.Sequence-import Database.YamSql.Internal.Table-import Database.YamSql.Internal.Type---- Schema ---data Schema = Schema- { schemaName :: SqlName- , schemaDescription :: Text- , schemaDependencies :: Maybe [SqlName]- , schemaFunctions :: Maybe [Function]- , schemaFunctionTemplates :: Maybe [FunctionTpl]- , schemaTables :: Maybe [Table]- , schemaTableTemplates :: Maybe [TableTpl]- , schemaRoles :: Maybe [Role]- , schemaSequences :: Maybe [Sequence]- , schemaPrivUsage :: Maybe [SqlName]- , schemaPrivSelectAll :: Maybe [SqlName]- , schemaPrivInsertAll :: Maybe [SqlName]- , schemaPrivUpdateAll :: Maybe [SqlName]- , schemaPrivDeleteAll :: Maybe [SqlName]- , schemaPrivSequenceAll :: Maybe [SqlName]- , schemaPrivExecuteAll :: Maybe [SqlName]- , schemaPrivAllAll :: Maybe [SqlName]- , schemaDomains :: Maybe [Domain]- , schemaTypes :: Maybe [Type]- , schemaExecPostInstall :: Maybe Text- , schemaExecPostInstallAndUpgrade :: Maybe Text- } deriving (Generic, Show, Data)--instance FromJSON Schema where- parseJSON = parseYamSql--instance ToJSON Schema where- toJSON = toYamSqlJson--instance ToSqlIdPart Schema where- sqlIdPart = schemaName- sqlIdPartType = const "SCHEMA"--data SqlContextObj a where- SqlContextObj :: ToSqlIdPart a => {- sqlObjectObject :: a- } -> SqlContextObj a--deriving instance Show (SqlContextObj a)--instance ToSqlId (SqlContextObj a) where- sqlId (SqlContextObj x) = SqlId $ SqlIdContentObj (sqlIdPartType x) (sqlIdPart x)--data SqlContextSqo a where SqlContextSqo:: ToSqlIdPart a => {- sqlSqoSchema:: Schema,- sqlSqoObject :: a- } -> SqlContextSqo a--deriving instance Show (SqlContextSqo a)--instance ToSqlId (SqlContextSqo a) where- sqlId (SqlContextSqo s x) = SqlId $ SqlIdContentSqo- (sqlIdPartType x)- (sqlIdPart s <.> sqlIdPart x)--data SqlContextSqoArgtypes a where SqlContextSqoArgtypes :: (ToSqlIdPart a, ToSqlIdPartArgs a) => {- sqlSqoArgtypesSchema:: Schema,- sqlSqoArgtypesObject :: a- } -> SqlContextSqoArgtypes a--deriving instance Show (SqlContextSqoArgtypes a)--instance ToSqlId (SqlContextSqoArgtypes a) where- sqlId (SqlContextSqoArgtypes s x) = SqlId $ SqlIdContentSqoArgtypes- (sqlIdPartType x)- (sqlIdPart s <.> sqlIdPart x)- (sqlIdPartArgs x)--data SqlContextSqoObj a0 a1 where SqlContextSqoObj :: (ToSqlIdPart a0, ToSqlIdPart a1) => {- sqlSqoObjectSchema :: Schema,- sqlSqoObject1 :: a0,- sqlSqoObject2 :: a1-} -> SqlContextSqoObj a0 a1--deriving instance Show (SqlContextSqoObj a0 a1)--instance ToSqlId (SqlContextSqoObj a0 a1) where- sqlId (SqlContextSqoObj s x1 x2) = SqlId $ SqlIdContentSqoObj- (sqlIdPartType x1 <> "-" <> sqlIdPartType x2)- (sqlIdPart s <.> sqlIdPart x1)- (sqlIdPart x2)--sqlIdNameOnly :: SqlContextSqoArgtypes a -> SqlName-sqlIdNameOnly (SqlContextSqoArgtypes s x) = (sqlIdPart s <.> sqlIdPart x)-
− src/Database/YamSql/Internal/Sequence.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Sequence where--import Database.YamSql.Internal.Basic--data Sequence = Sequence- { sequenceName :: SqlName- , sequenceIncrement :: Maybe Int- , sequenceMinValue :: Maybe Int- , sequenceMaxValue :: Maybe Int- , sequenceStartValue :: Maybe Int- , sequenceCache :: Maybe Int- , sequenceCycle :: Maybe Bool- -- PostgreSQL extension- , sequenceOwnedByColumn :: Maybe SqlName- } deriving (Generic, Show, Data)--instance FromJSON Sequence where- parseJSON = parseYamSql--instance ToJSON Sequence where- toJSON = toYamSqlJson--instance ToSqlIdPart Sequence where- sqlIdPart = sequenceName- sqlIdPartType = const "SEQUENCE"
src/Database/YamSql/Internal/SqlId.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-} module Database.YamSql.Internal.SqlId where @@ -23,51 +24,26 @@ sqlIdCode :: a -> Text sqlIdCode = toSqlCode . sqlId -class (Typeable a, ToSqlCode a, Eq a, Show a) =>- SqlIdContent a where- sqlIdContentType :: a -> SqlContextObjType--class Show a =>- ToSqlIdPart a where- sqlIdPart :: a -> SqlName- sqlIdPartType :: a -> SqlContextObjType--class ToSqlObjId a where- sqlObjId :: a -> SqlName- sqlObjIdCode :: a -> Text- sqlObjIdCode = toSqlCode . sqlObjId--class ToSqlSqoId a where- sqlSqoId :: a -> SqlName- sqlSqoIdCode :: a -> Text- sqlSqoIdCode = toSqlCode . sqlSqoId--class ToSqlSqoObjId a where- sqlSqoObjId :: a -> SqlName- sqlSqoObjIdCode :: a -> Text- sqlSqoObjIdCode = toSqlCode . sqlSqoObjId---- | Strings like /TABLE/-type SqlContextObjType = Text--class ToSqlIdPartArgs a where- sqlIdPartArgs :: a -> [SqlType]+class (Typeable a, ToSqlCode a, Eq a, Show a) => SqlIdContent a -- | SqlId data SqlId where- SqlId :: (SqlIdContent a) => { sqlIdContent :: a } -> SqlId+ SqlId :: (SqlObjType a, SqlIdContent b) => SqlObj a b -> SqlId -deriving instance Show SqlId+sqlIdShowType :: SqlId -> Text+sqlIdShowType (SqlId x) = tshow $ sqlObjType x -sqlIdType :: SqlId -> SqlContextObjType-sqlIdType (SqlId x) = sqlIdContentType x+sqlIdTypeCode :: SqlId -> Text+sqlIdTypeCode (SqlId x) = toSqlCode $ sqlObjType x +deriving instance Show SqlId+ instance Eq SqlId where SqlId x == SqlId y = Just x == cast y instance Ord SqlId where- SqlId x `compare` SqlId y =- case sqlIdContentType x `compare` sqlIdContentType y of+ (SqlId x) `compare` (SqlId y) =+ case toSqlCode (sqlObjType x) `compare` toSqlCode (sqlObjType y) of EQ -> toSqlCode x `compare` toSqlCode y x' -> x' @@ -75,86 +51,46 @@ sqlId = id instance ToSqlCode SqlId where- toSqlCode (SqlId x) = toSqlCode x---- | ROLE, DATABASE, SCHEMA-data SqlIdContentObj =- SqlIdContentObj SqlContextObjType- SqlName- deriving (Eq, Show)--instance SqlIdContent SqlIdContentObj where- sqlIdContentType (SqlIdContentObj x _) = x--instance ToSqlId SqlIdContentObj where- sqlId = SqlId--instance ToSqlCode SqlIdContentObj where- toSqlCode (SqlIdContentObj _ x) = toSqlCode x--instance ToSqlObjId SqlIdContentObj where- sqlObjId (SqlIdContentObj _ x) = x---- | TABLE-data SqlIdContentSqo =- SqlIdContentSqo SqlContextObjType- SqlName- deriving (Eq, Show)--instance SqlIdContent SqlIdContentSqo where- sqlIdContentType (SqlIdContentSqo x _) = x--instance ToSqlId SqlIdContentSqo where- sqlId = SqlId--instance ToSqlCode SqlIdContentSqo where- toSqlCode (SqlIdContentSqo _ x) = toSqlCode x--instance ToSqlSqoId SqlIdContentSqo where- sqlSqoId (SqlIdContentSqo _ x) = x+ toSqlCode (SqlId x) = toSqlCode $ sqlObjId x --- | TABLE TRIGGER, TABLE CONTRAINT-data SqlIdContentSqoObj =- SqlIdContentSqoObj SqlContextObjType- SqlName- SqlName- deriving (Eq, Show)+data SqlContext a = SqlContext a -instance SqlIdContent SqlIdContentSqoObj where- sqlIdContentType (SqlIdContentSqoObj x _ _) = x+-- FIXME+instance Show (SqlContext a) where show= const "" -instance ToSqlId SqlIdContentSqoObj where+instance (SqlObjType a, SqlIdContent b) => ToSqlId (SqlObj a b) where sqlId = SqlId -instance ToSqlCode SqlIdContentSqoObj where- toSqlCode (SqlIdContentSqoObj _ x y) = toSqlCode (x <.> y)+class (Typeable a, ToSqlCode a, Show a) => SqlObjType a -instance ToSqlSqoId SqlIdContentSqoObj where- sqlSqoId (SqlIdContentSqoObj _ x _) = x+data SqlObj a b where+ SqlObj :: (SqlObjType a, SqlIdContent b)+ => { sqlObjType :: a , sqlObjId :: b }+ -> SqlObj a b -instance ToSqlSqoObjId SqlIdContentSqoObj where- sqlSqoObjId (SqlIdContentSqoObj _ _ x) = x+deriving instance Show (SqlObj a b) --- | FUNCTION-data SqlIdContentSqoArgtypes =- SqlIdContentSqoArgtypes SqlContextObjType- SqlName- [SqlType]- deriving (Eq, Show)+instance Eq (SqlObj a b) where+ SqlObj x1 y1 == SqlObj x2 y2 = (typeOf x1) == (typeOf x2) && y1 == y2 -instance SqlIdContent SqlIdContentSqoArgtypes where- sqlIdContentType (SqlIdContentSqoArgtypes x _ _) = x+instance ToSqlCode (SqlObj a b) where+ toSqlCode (SqlObj _ x) = toSqlCode x -instance ToSqlId SqlIdContentSqoArgtypes where- sqlId = SqlId+instance SqlIdContent SqlName -instance ToSqlSqoId SqlIdContentSqoArgtypes where- sqlSqoId (SqlIdContentSqoArgtypes _ x _) = x+instance SqlIdContent (SqlName, SqlName)+instance ToSqlCode (SqlName, SqlName) where+ toSqlCode (x, y) = toSqlCode (x <.> y) -instance ToSqlCode SqlIdContentSqoArgtypes where- toSqlCode (SqlIdContentSqoArgtypes _ x ys) =+instance SqlIdContent (SqlName, [SqlType])+instance ToSqlCode (SqlName, [SqlType]) where+ toSqlCode (x, ys) = toSqlCode x <> "(" <> T.intercalate ", " (map toSqlCode ys) <> ")" +instance SqlIdContent (SqlName, SqlName, SqlName)+instance ToSqlCode (SqlName, SqlName, SqlName) where+ toSqlCode (x, _, y) = toSqlCode (x <.> y)+ -- ToSqlCode (right now only SqlName) unsafePlainName :: SqlName -> Text unsafePlainName (SqlName n) = n@@ -210,11 +146,22 @@ where quotedName (SqlName s) = "\"" <> s <> "\"" -class ToSqlCode a where+class ToSqlCode a where toSqlCode :: a -> Text +class ToSqlName a where+ toSqlName :: a -> SqlName+ class SqlIdentifierConcat a where (//) :: a -> a -> a++instance Monoid SqlName where+ mempty = SqlName ""+ mappend x@(SqlName x') y@(SqlName y')+ | x == mempty = y+ | y == mempty = x+ | otherwise = SqlName (x' <> "_" <> y')+ -- SqlName newtype SqlName =
− src/Database/YamSql/Internal/Table.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Table where--import Database.YamSql.Internal.Basic-import Database.YamSql.Internal.Check--data Table = Table- { tableName :: SqlName- , tableDescription :: Text- , tableColumns :: [Column]- , tablePrimaryKey :: [SqlName]- , tableUnique :: Maybe [UniqueKey]- , tableForeignKeys :: Maybe [ForeignKey]- , tableChecks :: Maybe [Check]- , tableInherits :: Maybe [SqlName]- , tablePrivSelect :: Maybe [SqlName]- , tablePrivInsert :: Maybe [SqlName]- , tablePrivUpdate :: Maybe [SqlName]- , tablePrivDelete :: Maybe [SqlName]- , tableTemplates :: Maybe [SqlName]- , tableTemplateData :: Maybe [TableTpl]- } deriving (Data, Generic, Show)--instance FromJSON Table where- parseJSON = parseYamSql--instance ToJSON Table where- toJSON = toYamSqlJson--instance ToSqlIdPart Table where- sqlIdPart = tableName- sqlIdPartType = const "TABLE"--data TableTpl = TableTpl- { tabletplTemplate :: SqlName- , tabletplDescription :: Text- , tabletplForeignKeys :: Maybe [ForeignKey]- , tabletplInherits :: Maybe [SqlName]- , tabletplColumns :: Maybe [Column]- , tabletplChecks :: Maybe [Check]- , tabletplPrivSelect :: Maybe [SqlName]- , tabletplPrivInsert :: Maybe [SqlName]- , tabletplPrivUpdate :: Maybe [SqlName]- , tabletplPrivDelete :: Maybe [SqlName]- } deriving (Generic, Show, Data)--instance FromJSON TableTpl where- parseJSON = parseYamSql--instance ToJSON TableTpl where- toJSON = toYamSqlJson--data Column = Column- { columnName :: SqlName- , columnType :: SqlType- , columnDescription :: Text- , columnDefault :: Maybe Text- , columnNull :: Maybe Bool- , columnReferences :: Maybe SqlName- , columnOnRefDelete :: Maybe Text- , columnOnRefUpdate :: Maybe Text- , columnUnique :: Maybe Bool- , columnChecks :: Maybe [Check]- } deriving (Generic, Show, Data)--instance FromJSON Column where- parseJSON = parseYamSql--instance ToJSON Column where- toJSON = toYamSqlJson--instance ToSqlIdPart Column where- sqlIdPart = columnName- sqlIdPartType = const "COLUMN"--applyTableTpl :: TableTpl -> Table -> Table-applyTableTpl tpl t =- t- { tableColumns = fromMaybe [] (tabletplColumns tpl) ++ tableColumns t- , tableForeignKeys = maybeJoin (tabletplForeignKeys tpl) (tableForeignKeys t)- , tableInherits = maybeJoin (tabletplInherits tpl) (tableInherits t)- , tableChecks = maybeJoin (tabletplChecks tpl) (tableChecks t)- , tablePrivSelect = maybeJoin (tabletplPrivSelect tpl) (tablePrivSelect t)- , tablePrivInsert = maybeJoin (tabletplPrivInsert tpl) (tablePrivInsert t)- , tablePrivUpdate = maybeJoin (tabletplPrivUpdate tpl) (tablePrivUpdate t)- , tablePrivDelete = maybeJoin (tabletplPrivDelete tpl) (tablePrivDelete t)- }--data UniqueKey = UniqueKey- { uniquekeyName :: SqlName- , uniquekeyColumns :: [SqlName]- } deriving (Generic, Show, Data)--instance FromJSON UniqueKey where- parseJSON = parseYamSql--instance ToJSON UniqueKey where- toJSON = toYamSqlJson--data ForeignKey = ForeignKey- { foreignkeyName :: SqlName- , foreignkeyColumns :: [SqlName]- , foreignkeyRefTable :: SqlName- , foreignkeyRefColumns :: [SqlName]- , foreignkeyOnDelete :: Maybe Text- , foreignkeyOnUpdate :: Maybe Text- } deriving (Generic, Show, Data)--instance FromJSON ForeignKey where- parseJSON = parseYamSql--instance ToJSON ForeignKey where- toJSON = toYamSqlJson
− src/Database/YamSql/Internal/Type.hs
@@ -1,37 +0,0 @@--- This file is part of HamSql------ Copyright 2014-2016 by it's authors.--- Some rights reserved. See COPYING, AUTHORS.-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Database.YamSql.Internal.Type where--import Database.YamSql.Internal.Basic--data Type = Type- { typeName :: SqlName- , typeDescription :: Text- , typeElements :: [TypeElement]- } deriving (Generic, Show, Data)--instance FromJSON Type where- parseJSON = parseYamSql--instance ToJSON Type where- toJSON = toYamSqlJson--data TypeElement = TypeElement- { typeelementName :: SqlName- , typeelementType :: SqlType- } deriving (Generic, Show, Data)--instance FromJSON TypeElement where- parseJSON = parseYamSql--instance ToJSON TypeElement where- toJSON = toYamSqlJson--instance ToSqlIdPart Type where- sqlIdPart = typeName- sqlIdPartType = const "TYPE"
+ test/hamsql-tests.hs view
@@ -0,0 +1,8 @@+module Main where++import Database.HamSql.Cli++main :: IO ()+main = do+ exec ["--help"] + where exec xs = parseThisArgv xs >>= run