Commit e54c36b8 authored by Michael Herold's avatar Michael Herold
Browse files

Completes the upgrade functionality

parent 47373e12
......@@ -19,5 +19,6 @@ dpkg-query -l \
libghc-yaml-dev \
libghc-missingh-dev \
libghc-pandoc-dev \
haskell-postgresql-simple
haskell-postgresql-simple \
optparse-applicative
......@@ -46,7 +46,9 @@ run (Upgrade opt optDb optUpgrade) = do
deleteStmts <- pgsqlDeleteAllStmt conn
createStmts <- pgsqlGetFullStatements opt optDb setup
let stmts = (sort deleteStmts) ++ (sort (Data.List.filter afterDelete createStmts))
fragile <- pgsqlUpdateFragile conn createStmts
let stmts = (sort deleteStmts) ++ (sort $ fragile ++ (Data.List.filter afterDelete createStmts))
useSqlStmts optDb stmts
......
......@@ -64,7 +64,10 @@ forceToJson s = do
(\handle -> hPutStrLn handle $ show $ toJSON s)
-- SqlCode (right now only SqlName)
instance Eq SqlName where
(==) x y = toSql x == toSql y
instance SqlCode SqlName
where
toSql (SqlName n) =
......@@ -124,7 +127,7 @@ class SqlCode a where
-- SqlName
newtype SqlName = SqlName String deriving (Generic,Ord,Show,Eq, Typeable, Data)
newtype SqlName = SqlName String deriving (Generic,Ord,Show, Typeable, Data)
instance FromJSON SqlName where parseJSON = genericParseJSON myOpt
instance ToJSON SqlName where toJSON = genericToJSON myOpt
......
-- This file is part of HamSql
--
-- Copyright 2014 by it's authors.
-- Copyright 2014-2015 by it's authors.
-- Some rights reserved. See COPYING, AUTHORS.
{-# LANGUAGE ScopedTypeVariables #-}
......@@ -14,6 +14,7 @@ import Database.PostgreSQL.Simple.Internal
import Network.URL
import qualified Data.ByteString.Char8 as B
import Data.String
import Data.List
import Option
import Parser
......@@ -124,7 +125,116 @@ pgsqlDeleteAllStmt conn = do
domain_constraints <- pgsqlDeleteDomainConstraintStmt conn
return $ function ++ table_constraints ++ domain_constraints
-- List existing objects
pgsqlListTables :: Connection -> IO [SqlName]
pgsqlListTables conn = do
dat :: [(String,String)] <- query_ conn $ toQry $
"SELECT table_schema, table_name" ++
" FROM information_schema.tables" ++
" WHERE table_type = 'BASE TABLE'" ++
" AND table_schema NOT IN ('information_schema', 'pg_catalog')"
return $ map toSqlName dat
where
toSqlName (s,t) = (SqlName s) <.> SqlName t
pgsqlListTableColumns :: Connection -> IO [(SqlName, SqlName)]
pgsqlListTableColumns conn = do
dat :: [(String, String, String)] <- query_ conn $ toQry $
"SELECT table_schema, table_name, column_name" ++
" FROM information_schema.columns" ++
--" WHERE table_type = 'BASE TABLE'" ++
" WHERE table_schema NOT IN ('information_schema', 'pg_catalog')"
return $ map toSqlName dat
where
toSqlName (s,t,u) = ((SqlName s) <.> SqlName t, SqlName u)
pgsqlListDomains :: Connection -> IO [SqlName]
pgsqlListDomains conn = do
dat :: [(String,String)] <- query_ conn $ toQry $
"SELECT domain_schema, domain_name" ++
" FROM information_schema.domains" ++
" WHERE domain_schema NOT IN ('information_schema', 'pg_catalog')"
return $ map toSqlName dat
where
toSqlName (s,t) = (SqlName s) <.> SqlName t
pgsqlListTypes :: Connection -> IO [SqlName]
pgsqlListTypes conn = do
dat :: [(String,String)] <- query_ conn $ toQry $
"SELECT user_defined_type_schema, user_defined_type_name" ++
" FROM information_schema.user_defined_types" ++
" WHERE user_defined_type_schema NOT IN ('information_schema', 'pg_catalog')"
return $ map toSqlName dat
where
toSqlName (s,t) = (SqlName s) <.> SqlName t
-- Fix missing or spare objects
pgsqlCorrectTables :: Connection -> [SqlStatement] -> IO [SqlStatement]
pgsqlCorrectTables conn stmtsInstall = do
existingNames <- pgsqlListTables conn
let expected = filter (SqlCreateTable `typeEq`) stmtsInstall
let existing = map (SqlCreateTable `replacesTypeOf`) $ map stmtDropTable existingNames
let stmtsCreate = expected \\ existing
let stmtsDrop = map (SqlDropTable `replacesTypeOf`) $ existing \\ expected
return $ stmtsCreate ++ stmtsDrop
pgsqlCorrectTableColumns :: Connection -> [SqlStatement] -> IO [SqlStatement]
pgsqlCorrectTableColumns conn stmtsInstall = do
existingNames <- pgsqlListTableColumns conn
let expected = filter (SqlAddColumn `typeEq`) stmtsInstall
let existing = map (SqlAddColumn `replacesTypeOf`) $ map stmtDropTableColumn existingNames
let stmtsCreate = expected \\ existing
let stmtsDrop = map (SqlDropColumn `replacesTypeOf`) $ existing \\ expected
return $ stmtsCreate ++ stmtsDrop
pgsqlCorrectDomains :: Connection -> [SqlStatement] -> IO [SqlStatement]
pgsqlCorrectDomains conn stmtsInstall = do
existingNames <- pgsqlListDomains conn
let expected = filter (SqlCreateDomain `typeEq`) stmtsInstall
let existing = map (SqlCreateDomain `replacesTypeOf`) $ map stmtDropDomain existingNames
let stmtsCreate = expected \\ existing
let stmtsDrop = map (SqlDropDomain `replacesTypeOf`) $ existing \\ expected
return $ stmtsCreate ++ stmtsDrop
pgsqlCorrectTypes :: Connection -> [SqlStatement] -> IO [SqlStatement]
pgsqlCorrectTypes conn stmtsInstall = do
existingNames <- pgsqlListTypes conn
let expected = filter (SqlCreateType `typeEq`) stmtsInstall
let existing = map (SqlCreateType `replacesTypeOf`) $ map stmtDropType existingNames
let stmtsCreate = expected \\ existing
let stmtsDrop = map (SqlDropType `replacesTypeOf`) $ existing \\ expected
return $ stmtsCreate ++ stmtsDrop
pgsqlUpdateFragile :: Connection -> [SqlStatement] -> IO [SqlStatement]
pgsqlUpdateFragile conn stmtsInstall = do
tables <- pgsqlCorrectTables conn stmtsInstall
columns <- pgsqlCorrectTableColumns conn stmtsInstall
domains <- pgsqlCorrectDomains conn stmtsInstall
types <- pgsqlCorrectTypes conn stmtsInstall
return $ tables ++ columns ++ domains ++ types
-- DB Utils
pgsqlHandleErr code e@(SqlError{}) =
err $
"sql error in following statement:\n" ++
......
......@@ -46,6 +46,7 @@ data SqlStatementType =
SqlDropTableConstraint |
SqlDropDomainConstraint |
-- DROP FUNCTION
SqlDropColumn |
SqlDropTable |
SqlDropFunction |
-- TABLE
......@@ -56,6 +57,8 @@ data SqlStatementType =
SqlAlterColumn |
SqlAddTableContraint |
-- FUNCTION
SqlDropDomain |
SqlDropType |
SqlCreateFunction |
SqlInherit |
SqlCreatePrimaryKeyConstr |
......
......@@ -14,7 +14,7 @@ import Data.Maybe
import Data.List
import Data.String.Utils (replace)
emptyName = undefined
emptyName = SqlName ""
stmtCommentOn :: SqlCode a => String -> a -> String -> SqlStatement
stmtCommentOn on obj com = SqlStmt SqlComment (SqlName $ toSql obj) $
......@@ -255,7 +255,7 @@ stmtsCreateTable opts setup t = debug opts "stmtCreateTable" $
moduleName' :: Table -> SqlName
moduleName' t' = moduleName $ tableParentModule $ tableInternal t'
-- Function
getFunctionStatements :: OptCommon -> Setup -> Function -> [SqlStatement]
......
......@@ -20,3 +20,21 @@ stmtDropDomainConstraint schema domain constraint = SqlStmt SqlDropDomainConstra
(SqlName schema <.> SqlName domain) $
"ALTER DOMAIN " ++ toSql(SqlName $ schema ++ "." ++ domain) ++
" DROP CONSTRAINT " ++ toSql(SqlName constraint) ++ ""
stmtDropTable :: SqlName -> SqlStatement
stmtDropTable t = SqlStmt SqlDropTable t $
"DROP TABLE " ++ toSql t
stmtDropTableColumn :: (SqlName, SqlName) -> SqlStatement
stmtDropTableColumn (t, c) = SqlStmt SqlDropColumn (t <.> c) $
"ALTER TABLE " ++ toSql t ++ " DROP COLUMN " ++ toSql c
stmtDropDomain :: SqlName -> SqlStatement
stmtDropDomain d = SqlStmt SqlDropDomain d $
"DROP DOMAIN " ++ toSql d
stmtDropType :: SqlName -> SqlStatement
stmtDropType t = SqlStmt SqlDropType t $
"DROP TYPE " ++ toSql t
\ No newline at end of file
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