diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Mark Fine + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/main/Apply.hs b/main/Apply.hs new file mode 100644 --- /dev/null +++ b/main/Apply.hs @@ -0,0 +1,48 @@ +import BasePrelude hiding ( FilePath ) +import Data.Text ( Text, pack ) +import Database.PostgreSQL.Schema ( bootstrap, converge ) +import Options.Applicative +import Paths_postgresql_schema ( getDataFileName ) +import Shelly + +data Args = Args + { aDir :: Maybe String + , aUrl :: Maybe String + } deriving ( Eq, Read, Show ) + +args :: ParserInfo Args +args = + info ( helper <*> args' ) + ( fullDesc + <> header "schema-apply: Apply Schema to PostgreSQL Database" + <> progDesc "Apply Schema" ) where + args' = Args + <$> optional ( strOption + ( long "dir" + <> metavar "DIR" + <> help "Migrations Directory" ) ) + <*> optional ( strOption + ( long "url" + <> metavar "URL" + <> help "Database URL" ) ) + +apply :: FilePath -> FilePath -> Text -> Sh () +apply bootstrapDir dir url = do + bootstrap bootstrapDir bootstrapTable schema url + converge dir table schema url where + bootstrapTable = "bootstrap_scripts" + table = "scripts" + schema = "schema_evolution_manager" + +exec :: String -> String -> String -> IO () +exec bootstrapDir dir url = + shelly $ + apply (fromText (pack bootstrapDir)) (fromText (pack dir)) (pack url) + +main :: IO () +main = + execParser args >>= call where + call Args{..} = do + url <- lookupEnv "DATABASE_URL" + bootstrapDir <- getDataFileName "migrations" + maybe (return ()) (exec bootstrapDir (fromMaybe "migrations" aDir)) (aUrl <|> url) diff --git a/migrations/20130318-105434.sql b/migrations/20130318-105434.sql new file mode 100644 --- /dev/null +++ b/migrations/20130318-105434.sql @@ -0,0 +1,64 @@ +-- This script initializes the schema_evolution_manager schema and the scripts and +-- the bootstrap_scripts tables + +create schema schema_evolution_manager; + +SET search_path TO schema_evolution_manager; + +create or replace function table_exists(p_schema_name character varying, p_table_name character varying) returns boolean + language plpgsql + as $$ +begin + perform 1 from information_schema.tables where table_schema = p_schema_name and table_name=p_table_name and table_type='BASE TABLE'; + return found; +end; +$$; + +create or replace function create_tables() returns void + language plpgsql + as $$ +begin + if not table_exists('schema_evolution_manager', 'scripts') then + + create table schema_evolution_manager.scripts ( + id bigserial, + filename varchar(100) not null, + created_at timestamp with time zone default now() not null + ); + + alter table schema_evolution_manager.scripts add constraint scripts_id_pk primary key(id); + alter table schema_evolution_manager.scripts add constraint scripts_filename_un unique(filename); + + comment on table schema_evolution_manager.scripts is ' + When a script is applied to this database, the script is recorded + here. This table is the used to ensure scripts are applied at most + once to this database. + '; + + end if; + + if not table_exists('schema_evolution_manager', 'bootstrap_scripts') then + + create table schema_evolution_manager.bootstrap_scripts ( + id bigserial, + filename varchar(100) not null, + created_at timestamp with time zone default now() not null + ); + + alter table schema_evolution_manager.bootstrap_scripts add constraint bootstrap_scripts_id_pk primary key(id); + alter table schema_evolution_manager.bootstrap_scripts add constraint bootstrap_scripts_filename_un unique(filename); + + comment on table schema_evolution_manager.bootstrap_scripts is ' + Internal list of schema_evolution_manager sql scripts applied. Used only for upgrades + to schema_evolution_manager itself. + '; + + end if; + +end; +$$; + +select create_tables(); + +drop function create_tables(); +drop function table_exists(character varying, character varying); diff --git a/migrations/20130318-105456.sql b/migrations/20130318-105456.sql new file mode 100644 --- /dev/null +++ b/migrations/20130318-105456.sql @@ -0,0 +1,135 @@ +-- library of common utility functions +set search_path to schema_evolution_manager; + +CREATE OR REPLACE FUNCTION create_basic_audit_data(p_schema_name character varying, p_table_name character varying) RETURNS void + LANGUAGE plpgsql + AS $$ +begin + perform schema_evolution_manager.create_basic_created_audit_data(p_schema_name, p_table_name); + perform schema_evolution_manager.create_basic_updated_audit_data(p_schema_name, p_table_name); + perform schema_evolution_manager.create_basic_deleted_audit_data(p_schema_name, p_table_name); +end; +$$; + +CREATE OR REPLACE FUNCTION create_basic_created_audit_data(p_schema_name character varying, p_table_name character varying) RETURNS void + LANGUAGE plpgsql + AS $$ +begin + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add created_by_guid uuid not null'; + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add created_at timestamp with time zone default now() not null'; +end; +$$; + +CREATE OR REPLACE FUNCTION create_basic_deleted_audit_data(p_schema_name character varying, p_table_name character varying) RETURNS void + LANGUAGE plpgsql + AS $$ +begin + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add deleted_by_guid uuid'; + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add deleted_at timestamp with time zone'; + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add constraint ' || p_table_name || '_deleted_ck ' || + 'check ( (deleted_at is null and deleted_by_guid is null) OR (deleted_at is not null and deleted_by_guid is not null) )'; + perform schema_evolution_manager.create_prevent_immediate_delete_trigger(p_schema_name, p_table_name); +end; +$$; + +CREATE OR REPLACE FUNCTION create_basic_updated_audit_data(p_schema_name character varying, p_table_name character varying) RETURNS void + LANGUAGE plpgsql + AS $$ +begin + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add updated_by_guid uuid not null'; + execute 'alter table ' || p_schema_name || '.' || p_table_name || ' add updated_at timestamp with time zone default now() not null'; + perform schema_evolution_manager.create_updated_at_trigger(p_schema_name, p_table_name); +end; +$$; + +CREATE OR REPLACE FUNCTION prevent_delete() RETURNS trigger + LANGUAGE plpgsql + AS $$ +begin + raise exception 'Physical deletes are not allowed on this table'; +end; +$$; + +CREATE OR REPLACE FUNCTION prevent_immediate_delete() RETURNS trigger + LANGUAGE plpgsql + AS $$ +begin + if old.deleted_at is null then + raise exception 'You must set the deleted_at column for this table'; + end if; + + if old.deleted_at > now() - interval '1 months' then + raise exception 'Physical deletes on this table can occur only after 1 month of deleting the records'; + end if; + + return old; +end; +$$; + +CREATE OR REPLACE FUNCTION create_updated_at_trigger(p_schema_name character varying, p_table_name character varying) RETURNS character varying + LANGUAGE plpgsql + AS $$ +declare + v_name varchar; +begin + v_name = p_table_name || '_updated_at_trigger'; + execute 'drop trigger if exists ' || v_name || ' on ' || p_schema_name || '.' || p_table_name; + execute 'create trigger ' || v_name || ' before update on ' || p_schema_name || '.' || p_table_name || ' for each row execute procedure schema_evolution_manager.set_updated_at_trigger_function()'; + return v_name; +end; +$$; + +CREATE OR REPLACE FUNCTION set_updated_at_trigger_function() RETURNS trigger + LANGUAGE plpgsql + AS $$ +begin + if (new.updated_at = old.updated_at) then + new.updated_at = timezone('utc', now())::timestamptz; + end if; + return new; +end; +$$; + +CREATE OR REPLACE FUNCTION create_prevent_immediate_delete_trigger(p_schema_name character varying, p_table_name character varying) RETURNS character varying + LANGUAGE plpgsql + AS $$ +declare + v_name varchar; +begin + v_name = p_table_name || '_prevent_immediate_delete_trigger'; + execute 'create trigger ' || v_name || ' before delete on ' || p_schema_name || '.' || p_table_name || ' for each row execute procedure schema_evolution_manager.prevent_immediate_delete()'; + return v_name; +end; +$$; + +CREATE OR REPLACE FUNCTION create_prevent_update_trigger(p_schema_name character varying, p_table_name character varying) RETURNS character varying + LANGUAGE plpgsql + AS $$ +declare + v_name varchar; +begin + v_name = p_table_name || '_prevent_update_trigger'; + execute 'create trigger ' || v_name || ' after update on ' || p_schema_name || '.' || p_table_name || ' for each row execute procedure schema_evolution_manager.prevent_update()'; + return v_name; +end; +$$; + +CREATE OR REPLACE FUNCTION create_prevent_delete_trigger(p_schema_name character varying, p_table_name character varying) RETURNS character varying + LANGUAGE plpgsql + AS $$ +declare + v_name varchar; +begin + v_name = p_table_name || '_prevent_delete_trigger'; + execute 'create trigger ' || v_name || ' after delete on ' || p_schema_name || '.' || p_table_name || ' for each row execute procedure schema_evolution_manager.prevent_delete()'; + return v_name; +end; +$$; + +CREATE OR REPLACE FUNCTION prevent_update() RETURNS trigger + LANGUAGE plpgsql + AS $$ +begin + raise exception 'Physical updates are not allowed on this table'; +end; +$$; diff --git a/postgresql-schema.cabal b/postgresql-schema.cabal new file mode 100644 --- /dev/null +++ b/postgresql-schema.cabal @@ -0,0 +1,48 @@ +name: postgresql-schema +version: 0.1.0 +synopsis: PostgreSQL Schema Management +description: Please see README.md +homepage: https://github.com/mfine/postgresql-schema +license: BSD3 +license-file: LICENSE +author: Mark Fine +maintainer: mark.fine@gmail.com +copyright: Copyright (C) 2015 Mark Fine +category: Database +build-type: Simple +cabal-version: >= 1.10 +data-files: migrations/20130318-105434.sql + , migrations/20130318-105456.sql + +library + exposed-modules: Database.PostgreSQL.Schema + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fno-warn-orphans + build-depends: base >= 4.7 && < 5 + , base-prelude + , formatting + , shelly + , text + default-extensions: NoImplicitPrelude + OverloadedStrings + +executable schema-apply + hs-source-dirs: main + main-is: Apply.hs + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , base-prelude + , formatting + , optparse-applicative + , postgresql-schema + , shelly + , text + default-extensions: NoImplicitPrelude + OverloadedStrings + RecordWildCards + +source-repository head + type: git + location: https://github.com/mfine/postgresql-schema diff --git a/src/Database/PostgreSQL/Schema.hs b/src/Database/PostgreSQL/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Schema.hs @@ -0,0 +1,107 @@ +module Database.PostgreSQL.Schema + ( bootstrap + , converge + ) where + +import BasePrelude hiding ( FilePath, (%), intercalate, lines ) +import Data.Text ( Text, intercalate, lines, strip ) +import Formatting ( (%), sformat, stext ) +import Shelly + +psqlCommand :: Text -> Text -> Sh Text +psqlCommand c url = + run "psql" [ "--no-align" + , "--tuples-only" + , "--command" + , c + , url ] + +psqlFile :: FilePath -> Text -> Sh () +psqlFile f url = + run_ "psql" [ "--no-align" + , "--tuples-only" + , "--quiet" + , "--file" + , toTextIgnore f + , url ] + +countSchema :: Text -> Text +countSchema schema = + sformat ( " SELECT count(*) " % + " FROM pg_namespace " % + " WHERE nspname = '" % stext % "' " ) + schema + +countMigration :: FilePath -> Text -> Text -> Text +countMigration migration table schema = + sformat ( " SELECT count(*) " % + " FROM " % stext % "." % stext % + " WHERE filename = '" % stext % "' " ) + schema table (toTextIgnore migration) + +insertMigration :: FilePath -> Text -> Text -> Text +insertMigration migration table schema = + sformat ( " INSERT INTO " % stext % "." % stext % " (filename) " % + " SELECT '" % stext % "' " % + " WHERE NOT EXISTS " % + " ( SELECT TRUE FROM " % stext % "." % stext % + " WHERE filename = '" % stext % "') " ) + schema table (toTextIgnore migration) schema table (toTextIgnore migration) + +selectMigrations :: [FilePath] -> Text -> Text -> Text +selectMigrations migrations table schema = + sformat ( " SELECT filename " % + " FROM " % stext % "." % stext % + " WHERE filename IN ( " % stext % " ) " ) + schema table $ + intercalate ", " $ flip map migrations $ \migration -> + sformat ("'" % stext % "'") (toTextIgnore migration) + +checkSchema :: Text -> Text -> Sh Bool +checkSchema schema url = do + r <- psqlCommand (countSchema schema) url + return $ strip r /= "0" + +checkMigration :: FilePath -> Text -> Text -> Text -> Sh Bool +checkMigration migration table schema url = do + r <- psqlCommand (countMigration migration table schema) url + return $ strip r /= "0" + +getMigrations :: [FilePath] -> Text -> Text -> Text -> Sh [FilePath] +getMigrations migrations table schema url = do + r <- psqlCommand (selectMigrations migrations table schema) url + return $ migrations \\ map fromText (lines r) + +findMigrations :: FilePath -> Sh [FilePath] +findMigrations dir = do + migrations <- findWhen test_f dir + forM migrations $ relativeTo dir + +migrate :: [FilePath] -> Text -> Text -> Text -> Sh () +migrate migrations table schema url = + withTmpDir $ \dir -> + forM_ migrations $ \migration -> do + check <- checkMigration migration table schema url + when check $ do + contents <- readfile migration + appendfile (dir migration) "\\set ON_ERROR_STOP true\n\n" + appendfile (dir migration) contents + appendfile (dir migration) $ insertMigration migration table schema + psqlFile (dir migration) url + +bootstrap :: FilePath -> Text -> Text -> Text -> Sh () +bootstrap dir table schema url = + chdir dir $ do + migrations <- findMigrations dir + check <- checkSchema schema url + when check $ + migrate migrations table schema url + migrations' <- getMigrations migrations table schema url + migrate migrations' table schema url + +converge :: FilePath -> Text -> Text -> Text -> Sh () +converge dir table schema url = + chdir dir $ do + migrations <- findMigrations dir + migrations' <- getMigrations migrations table schema url + migrate migrations' table schema url