Commit bc026bb3 authored by Sophie Herold's avatar Sophie Herold 🌼

Readds role upgrade support

parent 3255a129
Pipeline #852 passed with stage
in 4 minutes and 18 seconds
......@@ -38,17 +38,6 @@ parseThisArgv :: [String] -> IO Command
parseThisArgv xs =
handleParseResult $ execParserPure parserPrefs parserInfoHamsql xs
newSetup' :: [Schema] -> Setup
newSetup' s =
Setup
{ setupSchemas = []
, setupSchemaDirs = Nothing
, setupRolePrefix = Just "hamsql-test_"
, setupPreCode = Nothing
, setupPostCode = Nothing
, _setupSchemaData = Just s
}
run :: Command -> IO ()
-- Install
run (Install optCommon optDb optInstall)
......@@ -73,7 +62,8 @@ run (Install optCommon optDb optInstall)
"database exists for those commands to make sense."
dropRoleStmts <-
if optDeleteResidualRoles optInstall
then return [] --TODO: pgsqlDropAllRoleStmts optDb setup
then pgsqlConnectUrl (getConUrl optDb) >>=
runReaderT (pgsqlDropAllRoleStmts setup)
else return []
useSqlStmts optCommon optDb $ sort $ (stmtsInstall setup) ++ dropRoleStmts
-- Upgrade
......@@ -81,17 +71,11 @@ run (Upgrade optCommon optDb) = do
sourceSetup' <- loadSetup (optSetup optCommon)
conn <- pgsqlConnectUrl (getConUrl optDb)
sourceSetup <- runReaderT (normalizeOnline sourceSetup') conn
targetModules <- runReaderT deployedSchemas conn
let sourceStmts = stmtsInstall sourceSetup
let targetStmts = stmtsInstall $ newSetup' targetModules
let stmts =
sort $
(sourceStmts \\ targetStmts) ++
stmtsUpdateDrop (targetStmts \\ sourceStmts)
targetSetup <- runReaderT (inquireSetup $ setupRolePrefix sourceSetup') conn
let stmts = upgradeStmts sourceSetup targetSetup
--deleteStmts <- pgsqlDeleteAllStmt conn
--fragile <- pgsqlUpdateFragile setup conn (stmtsInstall setup)
--let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)
print $ stmts
useSqlStmts optCommon optDb stmts
-- Doc
run (Doc optCommon optDoc) = do
......
......@@ -14,8 +14,51 @@ import Database.HamSql.Internal.Utils
import Database.HamSql.Setup
import Database.YamSql
-- ** Schemas
-- * Database
inquireSetup ::
Maybe Text -- ^ Role prefix
-> SqlT Setup
inquireSetup rolePrefix = do
schemas <- deployedSchemas
roles <- inquireRoles rolePrefix
return
Setup
{ setupSchemas = []
, setupSchemaDirs = Nothing
, setupRolePrefix = rolePrefix
, setupPreCode = Nothing
, setupPostCode = Nothing
, _setupSchemaData = Just schemas
, setupRoles = presetEmpty roles
}
-- ** Roles
inquireRoles :: Maybe Text -> SqlT [Role]
inquireRoles prfx = do
roles <- psqlQry qry (Only $ prfx' <> "%")
mapM toRole roles
where
prfx' = fromMaybe "" prfx
toRole (name, description) =
return
Role
{ roleName = SqlName $ fromMaybe name (stripPrefix prfx' name)
, roleDescription = fromMaybe "" description
, roleLogin = Nothing
, rolePassword = Nothing
, roleMemberIn = Nothing
}
qry =
[sql|
SELECT
rolname,
pg_catalog.shobj_description(oid, 'pg_authid') AS desc
FROM pg_catalog.pg_roles
WHERE rolname LIKE ?
ORDER BY rolname
|]
-- ** Schemas
deployedSchemas :: SqlT [Schema]
deployedSchemas = do
schemas <- psqlQry_ qry
......@@ -62,8 +105,7 @@ deployedSchemas = do
-- TODO: do public right
|]
-- ** Tables
-- *** Tables
deployedTables :: SqlName -> SqlT [Table]
deployedTables schema = do
tbls <- psqlQry qry (Only $ toSqlCode schema)
......@@ -305,8 +347,7 @@ keyQuery =
GROUP BY tnsp.nspname, trel.relname, irel.relname;
|]
-- ** Functions
-- *** Functions
deployedFunctions :: SqlName -> SqlT [Function]
deployedFunctions schema = do
funs <- psqlQry qry (Only $ toSqlCode schema)
......@@ -367,8 +408,7 @@ toVariable varType varName varDefault =
, variableDefault = varDefault
}
-- ** Domains
-- *** Domains
deployedDomains :: SqlName -> SqlT [Domain]
deployedDomains schema = do
doms <- psqlQry qry (Only $ toSqlCode schema)
......@@ -421,8 +461,7 @@ deployedDomainConstraints dom = do
t.oid = ?::regtype::oid
|]
-- ** Sequences
-- *** Sequences
deployedSequences :: SqlName -> SqlT [Sequence]
deployedSequences schema = do
seqs <- psqlQry qry1 (Only $ toSqlCode schema)
......@@ -468,8 +507,7 @@ deployedSequences schema = do
"min_value, cache_value, is_cycled::bool, ?::text AS desc, ?::text AS ownedby FROM " <>
n
-- ** Types
-- *** Types
deployedTypes :: SqlName -> SqlT [Type]
deployedTypes schema = do
types <- psqlQry qry (Only $ toSqlCode schema)
......
......@@ -69,8 +69,9 @@ module Database.HamSql.Internal.PostgresCon
( stmtsInstall
, pgsqlExecWithoutTransact
, pgsqlExec
, stmtsUpdateDrop
, upgradeStmts
, normalizeOnline
, pgsqlDropAllRoleStmts
) where
import Control.Exception
......@@ -80,23 +81,22 @@ import qualified Data.ByteString.Char8 as B
--import Data.Function
import Data.Maybe
import Data.List ((\\), sort)
--import Data.Set (fromList, notMember)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Transaction
import Network.URI (URI)
import Database.HamSql.Internal.DbUtils
--import Database.HamSql.Internal.InquireDeployed
import Database.HamSql.Internal.InquireDeployed
import Database.HamSql.Internal.Option
import Database.HamSql.Internal.Stmt
import Database.HamSql.Internal.Stmt.Create
import Database.HamSql.Internal.Stmt.Domain
import Database.HamSql.Internal.Stmt.Function
import Database.HamSql.Internal.Stmt.Role
import Database.HamSql.Internal.Stmt.Schema
--import Database.HamSql.Internal.Stmt.Role
import Database.HamSql.Internal.Stmt.Sequence
import Database.HamSql.Internal.Stmt.Table
import Database.HamSql.Internal.Stmt.Trigger
......@@ -114,11 +114,24 @@ sqlErrUndefinedTable = "42P01"
stmtsInstall :: Setup -> [SqlStmt]
stmtsInstall setup = catMaybes $ getSetupStatements setup
stmtsUpdateDrop :: [SqlStmt] -> [SqlStmt]
stmtsUpdateDrop = catMaybes . concatMap dropStmt
pgsqlDropAllRoleStmts :: Setup -> SqlT [SqlStmt]
pgsqlDropAllRoleStmts s =
stmtsUpdateDrop s <$> catMaybes <$> getRoleStmts s <$>
inquireRoles (setupRolePrefix s)
upgradeStmts :: Setup -> Setup -> [SqlStmt]
upgradeStmts sourceSetup targetSetup =
let sourceStmts = stmtsInstall sourceSetup
targetStmts = stmtsInstall targetSetup
in sort $
(sourceStmts \\ targetStmts) ++
stmtsUpdateDrop sourceSetup (targetStmts \\ sourceStmts)
stmtsUpdateDrop :: Setup -> [SqlStmt] -> [SqlStmt]
stmtsUpdateDrop s = catMaybes . concatMap (dropStmt s)
dropStmt :: SqlStmt -> [Maybe SqlStmt]
dropStmt (SqlStmt (SqlStmtId t i) _) =
dropStmt :: Setup -> SqlStmt -> [Maybe SqlStmt]
dropStmt setup (SqlStmt (SqlStmtId t i) _) =
let n = SqlName $ toSqlCode i
s = expSqlName n
ncol = ((s !! 0) <.> (s !! 1), s !! 2)
......@@ -134,6 +147,7 @@ dropStmt (SqlStmt (SqlStmtId t i) _) =
stmtsDropTableConstr (SqlObj SQL_TABLE_CONSTRAINT ncol)
SqlCreateForeignKeyConstr ->
stmtsDropTableConstr (SqlObj SQL_TABLE_CONSTRAINT ncol)
SqlCreateRole -> stmtsDropRole setup (SqlObj SQL_ROLE n)
SqlDropSchema -> stmtsDropSchema (SqlObj SQL_SCHEMA n)
_ -> []
......
......@@ -59,13 +59,19 @@ sqlAddTransact xs =
catMaybes [newSqlStmt SqlUnclassified emptyName "BEGIN TRANSACTION"] ++
xs ++ catMaybes [newSqlStmt SqlUnclassified emptyName "COMMIT"]
getRoleStmts :: Setup -> [Role] -> [Maybe SqlStmt]
getRoleStmts s r =
concat $ map (toSqlStmts (SetupContext s)) $ map (SetupElement . SqlContext) r
-- | Setup
getSetupStatements :: Setup -> [Maybe SqlStmt]
getSetupStatements s =
[getStmt $ setupPreCode s] ++ schemaStatements ++ [getStmt $ setupPostCode s]
[getStmt $ setupPreCode s] ++
schemaStatements ++ myStmts ++ [getStmt $ setupPostCode s]
where
schemaStatements =
concat $ maybeMap (getSchemaStatements s) (_setupSchemaData s)
myStmts = getRoleStmts s $ fromMaybe [] $ setupRoles s
getStmt (Just code) = newSqlStmt SqlPre emptyName code
getStmt Nothing = Nothing
......
......@@ -41,6 +41,7 @@ data Setup = Setup
, setupPreCode :: Maybe Text
, setupPostCode :: Maybe Text
, _setupSchemaData :: Maybe [Schema]
, setupRoles :: Maybe [Role]
} deriving (Generic, Show, Data)
makeLenses ''Setup
......
......@@ -119,7 +119,7 @@ instance ToSqlCode SqlName where
else toSqlCode' $ expSqlName n'
instance SqlIdentifierConcat SqlName where
(//) (SqlName s) (SqlName t) = SqlName (s <> t)
(//) (SqlName s) (SqlName t) = SqlName (s <> T.replace "\"" "" t)
(<.>) :: SqlName -> SqlName -> SqlName
(<.>) (SqlName s) (SqlName t) = SqlName $ s <> "." <> t
......
......@@ -72,7 +72,7 @@ selfTestStmt :: String -> TestTree
selfTestStmt file =
testCaseSteps ("stmt " ++ file) $ \step -> do
(setupRemote, setupLocal) <- deploy step installSetup file
mapM_ (doWrite "/tmp/testout" . schemaToDirTree) $ onlyModules setupRemote
--mapM_ (doWrite "/tmp/testout" . schemaToDirTree) $ onlyModules setupRemote
step "check statement diff"
assertNoDiff
(sort $ stmtsInstall setupRemote)
......@@ -114,8 +114,8 @@ selfTestUpgradeDelete file =
step "check schema diff"
assertNoShowDiff (onlyModules setupRemote) (onlyModules setupLocal)
onlyModules :: Setup -> [Schema]
onlyModules = fromMaybe [] . _setupSchemaData
onlyModules :: Setup -> Setup
onlyModules s = s {setupSchemas = []}
deploy ::
(String -> IO ()) -> (String -> Assertion) -> String -> IO (Setup, Setup)
......@@ -124,12 +124,12 @@ deploy step f file = do
f file
step "retrive deployed from database ..."
con <- conn
schemasRemote <- runReaderT deployedSchemas con
setupLocal' <- loadSetup file
setupLocal <- runReaderT (normalizeOnline setupLocal') con
setupRemote <- runReaderT (inquireSetup $ setupRolePrefix setupLocal) con
close con
step "load setup ..."
return (newSetup schemasRemote, setupLocal)
return (setupRemote, setupLocal)
conn :: IO Connection
conn =
......@@ -160,6 +160,7 @@ upgradeSetupDelete s =
[ "upgrade"
, "--verbose"
, "--permit-data-deletion"
, "--delete-residual-roles"
, "-s"
, s
, "-c"
......@@ -168,17 +169,6 @@ upgradeSetupDelete s =
, "/tmp/del.sql"
]
newSetup :: [Schema] -> Setup
newSetup s =
Setup
{ setupSchemas = []
, setupSchemaDirs = Nothing
, setupRolePrefix = Just "hamsql-test_"
, setupPreCode = Nothing
, setupPostCode = Nothing
, _setupSchemaData = Just s
}
exec :: (Eq e, Exception e) => e -> [String] -> IO Bool
exec y xs =
handle (\x -> return $ x == y) (parseThisArgv xs >>= run >> return True)
......
......@@ -3,3 +3,7 @@ schemas:
- public
role_prefix: hamsql-test_
roles:
- name: myrole
description: a role
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment