├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── example ├── Main.hs ├── Setup.hs ├── recreate-example-db.sql └── refurb-example.cabal ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── refurb.cabal ├── src ├── Refurb.hs └── Refurb │ ├── Cli.hs │ ├── MigrationUtils.hs │ ├── Run │ ├── Backup.hs │ ├── Info.hs │ ├── Internal.hs │ └── Migrate.hs │ ├── Store.hs │ └── Types.hs └── test ├── Main.hs └── MigrationUtilsSpec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist-newstyle/ 3 | 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Confer Health, Inc. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Confer Health nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## `refurb` 2 | 3 | Refurb is a library for building PostgreSQL database migration software. Over the course of developing a database-backed software product in a team, you'll want to make organized updates to the database's schema and data that can be automatically reproduced in other environments. Refurb implements this process for Haskell projects in a fairly straightforward way, where individual changes to the database are applied in order by Haskell actions you make and check in with your code as usual. 4 | 5 | ### Quick tour 6 | 7 | `refurb` is a library whose primary public interface is `Refurb.refurbMain` and is intended to implement a command-line tool, much like `Setup.hs` uses `defaultMain` from Cabal (the library) to implement the build system or `test/Main.hs` might use `hspec`. You pass a list of `Migration`s to `refurbMain` along with a way to obtain the database connection parameters, and the library will take care of creating and maintaining an in-database list of applied migrations and providing a CLI for users to apply migrations, query applied migrations, and make backups. 8 | 9 | A `Migration` is a small structure with: 10 | 11 | * What PostgreSQL schema to apply the migration to. All migrations are qualified by the schema they apply to and schemas are automatically created by Refurb if they don't already exist. 12 | * A key to identify the migration within the schema, for example `create-first-table`. 13 | * An execution action of the type `MonadMigration m => m ()` which is invoked to apply the actual change, e.g. issue some `create table` statements. 14 | * An optional check action of the type `MonadMigration m => Maybe (m ())` which is invokved prior to the execution action to check preconditions. It can signal errors (much as the execution action can) to abort the migration from being executed and is present purely to help you organize your code. It's run just like the execution action is, if present. 15 | 16 | A working example is located in the `example/` directory. It's not a complete worked example project, as in a normal project you'd have your own product code as well as the migration related code presented in the example. 17 | 18 | ### Using refurb in your project 19 | 20 | While `example/` contains a working example of refurb, it doesn't reflect totally how you might use it in your own project. Project organization is in the end up to you and who you work with of course, but here's how we arrange our projects with Refurb: 21 | 22 | * `package.yaml` - [hpack](https://github.com/sol/hpack) file which generates `myawesomeserver.cabal`. If you're not familiar with hpack, it's not required. It's just a nicer way to generate cabal files than by hand. 23 | * `myawesomeserver.cabal` - generated by hpack and contains: 24 | * A library section with sources in `src/` (`hs-source-dirs: src` in cabal terms). `src` contains all the primary code of your product. 25 | * An executable section `myawesomeserver-exe` with sources in `app/server/` that depends on the `myawesomeserver` library. This executable launches your main product (presumably a server). This launch expects that the database has already been migrated and doesn't use refurb directly. 26 | * An executable section `myawesomeserver-refurb` with sources in `app/refurb/` that depends on the `myawesomeserver` and `refurb` libraries. This executable runs refurb for your project. 27 | * One or more other test suites or executable sections. At Confer, we have another executable which makes starting and stopping a development environment with PostgreSQL easy, for example. 28 | * `app/server/Main.hs` - main entry point to your server. Usually just calls something in the `myawesomeserver` library. 29 | * `app/refurb/Main.hs` - entry point for refurb. Usually just calls `refurbMain` with your list of migrations. Those migrations could be in `app/refurb/` or in your main `src/`. 30 | * `src/` - directory with your main product source files. 31 | 32 | With this arrangement a build produces both `myawesomeserver-exe` and `myawesomeserver-refurb`. Make sure to run `myawesomeserver-refurb migrate --execute` before running `myawesomeserver-exe` so the database gets migrated before the server tries to start. 33 | 34 | ### Invoking a refurb executable 35 | 36 | `refurb` implements a CLI to query what migrations have been applied to a database, query what would happen prior to actually migrating, and migrating. It's broken into several subcommands which perform different maintenance functions. There are also a few top-level switches: 37 | 38 | ``` 39 | Available options: 40 | -h,--help Show this help text 41 | -d,--debug Turn on debug diagnostic logging 42 | --no-color disable ANSI colorization 43 | -c,--config SERVER-CONFIG 44 | Path to server config file to read database 45 | connection information from 46 | ``` 47 | 48 | * `-h` / `--help` shows that help output. 49 | * `-d` / `--debug` turns on extra execution logging. Note that all log messages produced by a migration action are always captured, even with this switch off. This merely controls the console output. 50 | * `--no-color` suppresses ANSI colorization, e.g. for CI builds. 51 | * `-c` / `--config` tells `refurb` where to find the server's config file. `refurb` itself doesn't care about the file contents, it just passes the config file path off to the function given to `refurbMain` to get the database connection information back. 52 | 53 | #### `show-log` 54 | 55 | `myawesomeserver-refurb -c configfile show-log` shows a complete list of migrations known about and applied to the database. It displays a table similar to the following though with glorious ANSI coloration unless you suppress it with `--no-color`: 56 | 57 | ``` 58 | ID Timestamp Duration Result Key 59 | 1 2017-04-03 15:27:17 5 milliseconds success example.create-first-table 60 | not applied example.populate-first-table (seed data) 61 | ``` 62 | 63 | Each column is probably self-explanatory, but: 64 | 65 | * `ID` is the primary key in the `refurb.migration-log`. If this column is populated, it means that the corresponding migration was applied at some point for better or worse. 66 | * `Timestamp` is the time and date (in UTC) when the migration was applied to the database. Shows `not applied` if the migration hasn't been applied. 67 | * `Duration` is how long the migration took to execute when it was applied. If empty, it means the migration hasn't been applied. 68 | * `Result` indicates whether the migration application succeeded or failed. If empty, it means the migration hasn't been applied. 69 | * `Key` shows the qualified (that is, with schema) key of the migration along with a parenthetical note for seed data migrations. 70 | 71 | #### `show-migration` 72 | 73 | `myawesomeserver-refurb -c configfile show-migration example.create-first-table` shows the status of and log from the application of `example.create-first-table`. Naturally, if the migration has never been applied then no log will be available. 74 | 75 | For example: 76 | 77 | ``` 78 | ID Timestamp Duration Result Key 79 | 1 2017-04-03 15:27:17 5 milliseconds success example.create-first-table 80 | 81 | 2017-04-03 15:27:17.780579 [LevelDebug] create sequence first_table_seq @(refurb-0.2.0.0-eWyEcrirqVIapweij3svH:Refurb.MigrationUtils src/Refurb/MigrationUtils.hs:98:3) 82 | 2017-04-03 15:27:17.782271 [LevelDebug] create table first_table (id int not null primary key default nextval('first_table_seq'), t text not null) @(refurb-0.2.0.0-eWyEcrirqVIapweij3svH:Refurb.MigrationUtils src/Refurb/MigrationUtils.hs:98:3) 83 | ``` 84 | 85 | ### `backup` 86 | 87 | `myawesomeserver-refurb -c configfile backup path/to/backupfile` creates a compressed binary database backup using `pg_dump` which can be restored with `pg_restore`. You can also trigger a backup automatically before migration with the `-b path/to/backupfile` switch to `migrate`. 88 | 89 | ### `migrate` 90 | 91 | `myawesomeserver-refurb -c configfile migrate` is the main purpose of `refurb` - applying migrations to a database. If given no additional options it will consult the database and known migration list and display a list of migrations that would be executed. As a safety measure those migrations do not actually get executed unless you confirm that you want your database altered with `-e` / `--execute`. 92 | 93 | By default the list of migrations to apply will be only the schema migrations and not seed data migrations (see next section for more); in a development or QA environment where you want seed data, pass `-s` / `--seed` to see what migrations including seed data migrations would be applied and pass `-s -e` / `--seed --execute` to actually apply them. 94 | 95 | You can additionally request that the database be backed up prior to migration using `-b` / `--backup` and passing the path where you want the backup file created. 96 | 97 | ### Migration types 98 | 99 | Migrations come in two flavors: `schemaMigration` and `seedDataMigration`. The former type are run everywhere, while the second type are only run when requested with `--seed` and the `refurb.config` table doesn't have the `prod_system` flag set. The two types are intended to help with a common workflow, where in development and QA environments it's helpful to have seed data installed in your database, e.g. test users and configuration. Conversely seed data should never make its way into production, especially when installing that seed data might be destructive. 100 | 101 | Other than when they run, both types are equivalent in functionality. 102 | 103 | As an extra check to make it hard to accidentally apply seed data migrations to production systems, `refurb` will flatly refuse to run any seed data migrations when the `prod_system` boolean is true in `refurb.config`. It's not possible to set this boolean via the `refurb` CLI, so just `update refurb.config set prod_system = 't'` to set it. 104 | 105 | ### Migration actions 106 | 107 | Migration actions are Haskell actions of the type `MonadMigration m => m ()`. `MonadMigration` is defined this way (with `ConstraintKinds`): 108 | 109 | ```haskell 110 | type MonadMigration m = 111 | ( MonadBaseControl IO m -- access to underlying IO 112 | , MonadMask m -- can use bracket and friends 113 | , MonadReader PG.Connection m -- can ask for a connection to the DB 114 | , MonadLogger m -- can log using monad-logger 115 | ) 116 | ``` 117 | 118 | The database connection is of type `PG.Connection` with `PG` being `Database.PostgreSQL.Simple` from [`postgresql-simple`](https://github.com/lpsmith/postgresql-simple). So at its most basic a migration action could use that connection straightforwardly: 119 | 120 | ```haskell 121 | executeMyMigration :: MonadMigration m => m () 122 | executeMyMigration = do 123 | conn <- ask 124 | rowsAffected <- PG.execute_ conn "create table foo (bar text)" 125 | $logInfo "created foo!" 126 | pure () 127 | ``` 128 | 129 | Though this can be simplified as `refurb` provides several shorthands and utilities for writing migrations. They're located in the `Refurb.MigrationUtils` module and re-exported by `Refurb`. The previous example could be shortened to: 130 | 131 | ```haskell 132 | executeMyMigration :: MonadMigration m => m () 133 | executeMyMigration = 134 | void $ execute_ "create table foo (bar text)" 135 | ``` 136 | 137 | `execute_` being a helper which asks for the database connection and runs some query against it, logging that query at debug level. 138 | 139 | #### Migration action helpers 140 | 141 | These helpers are all located in `Refurb.MigrationUtils`, so go there for more details. 142 | 143 | * `execute` / `execute_` executes a single SQL statement which doesn't produce table output. The `_` version takes a literal query, while the non-`_` version takes a parameterized query along with parameters to substitute in. See `qqSql` below for a helper quasiquote which makes embedding a multiline SQL statement more pleasant. 144 | * `executeMany` / `executeSeries_` execute a series of SQL statements which don't produce table output. The `_` version takes a literal query, while the non-`_` version takes a parameterized query along with parameters to substitute in. See `qqSqls` below for a helper quasiquote which makes embedding multiple statement SQL scripts more pleasant. 145 | * `query` / `query_` executes a SQL query and return the results as a list using `postgresql-simple`'s `FromRow` machinery. The `_` version takes a literal query, while the non-`_` version takes a parameterized query along with parameters to substitute in. 146 | * `runQuery` executes an [Opaleye](https://github.com/tomjaguarpaw/haskell-opaleye) `Query`. `refurb` internally uses Opaleye to manage its storage tables, so this comes at no extra cost in dependency terms. 147 | * `runInsertMany` inserts a series of rows into a table using Opaleye. 148 | * `runUpdate` updates rows in a table using Opaleye. 149 | * `runDelete` deletes rows from a table using Opaleye. 150 | * `doesSchemaExist` checks if a schema exists or not using `information_schema`. Note that this is not typically required as `refurb` automatically creates schemas for you if they don't already exist. 151 | * `doesTableExist` check if a table exists or not in a given schema using `information_schema`. 152 | 153 | #### SQL embedding quasiquotes 154 | 155 | Writing SQL as string literals can get very tedious as Haskell doesn't have a separate multiline string literal syntax and instead relies on `\` to elide the newlines. To make embedding SQL queries in code easier, `refurb` provides two quasiquotes: `qqSql` and `qqSqls`. 156 | 157 | `qqSql` is essentially a multiline string literal and `[qqSql|foo|]` is equivalent to `"foo" :: PG.Query`. 158 | 159 | `qqSqls` is more complicated and intended for use with `executeSeries_`. It implements a simplistic version of the `;` delimited syntax common in SQL REPLs and yields a `[Query]`. 160 | 161 | For example: 162 | 163 | ```haskell 164 | queries :: [PG.Query] 165 | queries = 166 | [qqSqls| 167 | create sequence stuff_seq; 168 | create table stuff 169 | ( id bigint not null primary key default nextval('stuff_seq') 170 | ); 171 | |] 172 | ``` 173 | 174 | is equivalent to: 175 | 176 | ```haskell 177 | queries = 178 | [ "create sequence stuff_seq\n" 179 | , "create table stuff\n( id bigint not null primary key default nextval('stuff_seq')\n)\n" 180 | ] 181 | ``` 182 | 183 | As mentioned, it only implements a simplistic `;` delimited syntax. It separates statements whenever a `;` occurs at the beginning or end of line after stripping whitespace. Thus if you have a literal `;` don't put it at beginning or end of line, and conversely don't have more than one statement per line. 184 | 185 | ### Migration logs and output 186 | 187 | Migrations usually produce log entries as they execute, e.g. with the DDL statements they execute. This output is copied to the console output as the migrations run if the log message is at info or higher, or if `-d` / `--debug` is given when running `migrate --execute`. This output (including debug messages) is also captured and stored in the `refurb.migration_log` table for later perusal using `show-migration`. 188 | 189 | ### Failed migrations 190 | 191 | Presently if a migration fails refurb will store a record of it along with the logs from the failing migration and will never try to apply that migration again because there's no general safe way to untangle what the migration might have done before it failed. The intended pattern is that if a migration fails, you figure out what went wrong and untangle it and then either update the existing `refurb.migration_log` to be marked successful, or remove the record and rerun the migration. 192 | 193 | Failure of a migration is currently done by using either `fail` or throwing an exception from the migration execution or check action. 194 | 195 | Future improvements to the handling of failed migrations might be implemented, and suggestions are welcome. 196 | 197 | ### `refurb` schema 198 | 199 | Refurb maintains its own schema to keep track of applied migrations, both for informational purposes and to determine which known migrations (i.e. those given to `refurbMain`) have not yet been applied and need execution. 200 | 201 | The `refurb` schema contains two tables: `migration_log` and `config`. `migration_log` contains a record for each migration applied. 202 | 203 | `config` has only one column presently, `prod_system`. `prod_system` is a boolean whose only effect is to disable the application of seed data migrations (when `t`rue). 204 | 205 | `migration_log` has several columns: 206 | 207 | * `id` - primary key, serially assigned. 208 | * `qualified_key` - the migration's key qualified by its schema in `schema.key` form, e.g. `example.create-first-table`. 209 | * `applied` - timestamp when the migration was applied. 210 | * `output` - the log output of the migration application. 211 | * `result` - either `success` or `failure`. 212 | * `duration` - number of (fractional) seconds the migration took to execute. 213 | 214 | ### Long term maintenance 215 | 216 | One issue with using Haskell migration actions is that over time the migrations for a previous version might use types which no longer exist or have different definitions and thus not compile or do the wrong thing. It's up to you to decide what works best for your project. If you use mostly `execute` style migrations with embedded SQL there might not be a problem. Alternatively, you could keep old versions of data structures around for migrations to use, or comment out old migrations between releases and rely on running previous releases' migrations. 217 | 218 | Suggestions and contributions welcome to assist with various strategies here. 219 | 220 | ## Maturity 221 | 222 | As of writing, we use this library in our Haskell project which employs a database and have had no major issues. We have not yet released to production and have not gone through a series of releases, so improvements in the long term use might still be due. We'd appreciate any fixes, improvements, or experience reports. 223 | 224 | ## Contributing 225 | 226 | Contributions and feedback welcome! File and issue or make a PR. 227 | 228 | ## Chat 229 | 230 | Asa (@asa) and Ross (@dridus) lurk on [fpchat](https://fpchat.com). You can also reach us at `oss@confer.health`. 231 | 232 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | example 4 | 5 | package postgresql-libpq 6 | flags: +use-pkg-config 7 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import Control.Monad.Catch (throwM) 5 | import Database.PostgreSQL.Simple (ConnectInfo(ConnectInfo), Only(Only)) 6 | import Refurb 7 | ( Migration, schemaMigration, seedDataMigration, withCheck 8 | , MonadMigration, doesTableExist, execute_, executeMany 9 | , refurbMain 10 | ) 11 | 12 | data MigrationException = MigrationException Text 13 | deriving (Eq, Show) 14 | 15 | instance Exception MigrationException 16 | 17 | migrations :: [Migration] 18 | migrations = 19 | [ schemaMigration "example" "create-first-table" createFirstTable 20 | , seedDataMigration "example" "populate-first-table" populateFirstTable `withCheck` firstTableMustExist 21 | ] 22 | 23 | createFirstTable :: MonadMigration m => m () 24 | createFirstTable = do 25 | void $ execute_ "create sequence first_table_seq" 26 | void $ execute_ "create table first_table (id int not null primary key default nextval('first_table_seq'), t text not null)" 27 | 28 | firstTableMustExist :: MonadMigration m => m () 29 | firstTableMustExist = 30 | doesTableExist "example" "first_table" >>= bool (throwM $ MigrationException "first_table doesn't exist!!") (pure ()) 31 | 32 | populateFirstTable :: MonadMigration m => m () 33 | populateFirstTable = 34 | void $ executeMany "insert into first_table (t) values (?)" 35 | (map (Only . asText) $ words "foo bar baz") 36 | 37 | main :: IO () 38 | main = refurbMain (const . pure $ ConnectInfo "localhost" 5432 "example" "example" "example") migrations 39 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/recreate-example-db.sql: -------------------------------------------------------------------------------- 1 | drop database if exists example; 2 | drop user if exists example; 3 | 4 | create database example; 5 | create user example; 6 | grant all privileges on database example to example; 7 | 8 | -------------------------------------------------------------------------------- /example/refurb-example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | name: refurb-example 4 | version: 0.1.0.0 5 | synopsis: Tools for maintaining a database 6 | description: Tools for maintaining a database 7 | category: Database 8 | homepage: https://github.com/ConferHealth/refurb#readme 9 | maintainer: it@confer.care 10 | copyright: 2017 Confer Health, Inc. 11 | build-type: Simple 12 | 13 | executable refurb-example-exe 14 | main-is: Main.hs 15 | default-extensions: 16 | Arrows 17 | ConstraintKinds 18 | DataKinds 19 | DeriveGeneric 20 | FlexibleContexts 21 | FlexibleInstances 22 | GADTs 23 | GeneralizedNewtypeDeriving 24 | LambdaCase 25 | MultiParamTypeClasses 26 | NamedFieldPuns 27 | NoImplicitPrelude 28 | OverloadedStrings 29 | PatternSynonyms 30 | QuasiQuotes 31 | RankNTypes 32 | RecordWildCards 33 | ScopedTypeVariables 34 | StandaloneDeriving 35 | TemplateHaskell 36 | TypeApplications 37 | TypeFamilies 38 | TypeOperators 39 | ViewPatterns 40 | ghc-options: -Wall -Werror -O2 41 | build-depends: 42 | base >=4.7 && <5 43 | , classy-prelude 44 | , exceptions 45 | , postgresql-simple 46 | , refurb 47 | other-modules: 48 | Paths_refurb_example 49 | default-language: Haskell2010 50 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "composite": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1701717140, 7 | "narHash": "sha256-YxkFMAkBXXZJccb2VijYj0fPn+3rZyDSh2CI8jJK0Hc=", 8 | "owner": "composite-hs", 9 | "repo": "composite", 10 | "rev": "e90f04c67bd273d5d52daa55594b6c753dadfdaf", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "composite-hs", 15 | "repo": "composite", 16 | "rev": "e90f04c67bd273d5d52daa55594b6c753dadfdaf", 17 | "type": "github" 18 | } 19 | }, 20 | "composite-base": { 21 | "flake": false, 22 | "locked": { 23 | "lastModified": 1701717116, 24 | "narHash": "sha256-+QHegQnR5+lRZnrrJd8SrTWUNuHt+xIZECwebX/F+JA=", 25 | "owner": "composite-hs", 26 | "repo": "composite-base", 27 | "rev": "d946fb096f777cb99482b0f8899d6aff13811932", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "composite-hs", 32 | "repo": "composite-base", 33 | "rev": "d946fb096f777cb99482b0f8899d6aff13811932", 34 | "type": "github" 35 | } 36 | }, 37 | "flake-parts": { 38 | "inputs": { 39 | "nixpkgs-lib": "nixpkgs-lib" 40 | }, 41 | "locked": { 42 | "lastModified": 1709336216, 43 | "narHash": "sha256-Dt/wOWeW6Sqm11Yh+2+t0dfEWxoMxGBvv3JpIocFl9E=", 44 | "owner": "hercules-ci", 45 | "repo": "flake-parts", 46 | "rev": "f7b3c975cf067e56e7cda6cb098ebe3fb4d74ca2", 47 | "type": "github" 48 | }, 49 | "original": { 50 | "owner": "hercules-ci", 51 | "repo": "flake-parts", 52 | "type": "github" 53 | } 54 | }, 55 | "haskell-flake": { 56 | "locked": { 57 | "lastModified": 1710675764, 58 | "narHash": "sha256-ZpBoh1dVLTxC3wccOnsji7u/Ceuwh2raQn/Vq6BBYwo=", 59 | "owner": "srid", 60 | "repo": "haskell-flake", 61 | "rev": "ef955d7d239d7f82f343b569a4cf2c7c1a4df1f4", 62 | "type": "github" 63 | }, 64 | "original": { 65 | "owner": "srid", 66 | "repo": "haskell-flake", 67 | "type": "github" 68 | } 69 | }, 70 | "nixpkgs": { 71 | "locked": { 72 | "lastModified": 1711048004, 73 | "narHash": "sha256-fI9nyTXbQsZYNre67OXz0nNgcXXlNfN470WJv8Qw3eE=", 74 | "owner": "NixOS", 75 | "repo": "nixpkgs", 76 | "rev": "8c2a8f922ff4eb12bc2d6d1486f247ee3f02279e", 77 | "type": "github" 78 | }, 79 | "original": { 80 | "id": "nixpkgs", 81 | "ref": "release-23.11", 82 | "type": "indirect" 83 | } 84 | }, 85 | "nixpkgs-lib": { 86 | "locked": { 87 | "dir": "lib", 88 | "lastModified": 1709237383, 89 | "narHash": "sha256-cy6ArO4k5qTx+l5o+0mL9f5fa86tYUX3ozE1S+Txlds=", 90 | "owner": "NixOS", 91 | "repo": "nixpkgs", 92 | "rev": "1536926ef5621b09bba54035ae2bb6d806d72ac8", 93 | "type": "github" 94 | }, 95 | "original": { 96 | "dir": "lib", 97 | "owner": "NixOS", 98 | "ref": "nixos-unstable", 99 | "repo": "nixpkgs", 100 | "type": "github" 101 | } 102 | }, 103 | "root": { 104 | "inputs": { 105 | "composite": "composite", 106 | "composite-base": "composite-base", 107 | "flake-parts": "flake-parts", 108 | "haskell-flake": "haskell-flake", 109 | "nixpkgs": "nixpkgs" 110 | } 111 | } 112 | }, 113 | "root": "root", 114 | "version": 7 115 | } 116 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | composite-base = { 4 | url = "github:composite-hs/composite-base?rev=d946fb096f777cb99482b0f8899d6aff13811932"; 5 | flake = false; 6 | }; 7 | composite = { 8 | url = "github:composite-hs/composite?rev=e90f04c67bd273d5d52daa55594b6c753dadfdaf"; 9 | flake = false; 10 | }; 11 | flake-parts.url = "github:hercules-ci/flake-parts"; 12 | haskell-flake.url = "github:srid/haskell-flake"; 13 | nixpkgs.url = "nixpkgs/release-23.11"; 14 | }; 15 | 16 | outputs = inputs: 17 | inputs.flake-parts.lib.mkFlake {inherit inputs;} { 18 | systems = ["aarch64-linux" "x86_64-linux"]; 19 | imports = [ 20 | inputs.haskell-flake.flakeModule 21 | ]; 22 | perSystem = { 23 | self', 24 | system, 25 | lib, 26 | config, 27 | pkgs, 28 | ... 29 | }: { 30 | _module.args.pkgs = inputs.nixpkgs.legacyPackages.${system}; 31 | devShells.default = pkgs.mkShell { 32 | name = "refurb-devshell"; 33 | inputsFrom = [ 34 | config.haskellProjects.default.outputs.devShell 35 | ]; 36 | }; 37 | haskellProjects.default = { 38 | autoWire = []; 39 | devShell.tools = hp: {inherit (hp) fourmolu;}; 40 | packages = { 41 | composite-base.source = inputs.composite-base; 42 | composite-opaleye.source = inputs.composite + "/composite-opaleye"; 43 | }; 44 | settings = { 45 | composite-base.jailbreak = true; 46 | composite-opaleye.jailbreak = true; 47 | }; 48 | }; 49 | packages = rec { 50 | default = refurb; 51 | refurb = config.haskellProjects.default.outputs.packages.refurb.package; 52 | refurb-example = config.haskellProjects.default.outputs.packages.refurb-example.package; 53 | }; 54 | }; 55 | }; 56 | } 57 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | comma-style: trailing 3 | import-export-comma-style: trailing 4 | record-brace-space: true 5 | indent-wheres: true 6 | diff-friendly-import-export: true 7 | respectful: false 8 | haddock-style: single-line 9 | newlines-between-decls: 1 10 | -------------------------------------------------------------------------------- /refurb.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: refurb 3 | version: 0.3.0.3 4 | synopsis: Tools for maintaining a database 5 | description: Tools for maintaining a database 6 | category: Database 7 | homepage: https://github.com/ConferOpenSource/refurb#readme 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020 Vital Biosciences 10 | license: BSD3 11 | license-file: LICENSE 12 | build-type: Simple 13 | 14 | library 15 | exposed-modules: 16 | Refurb 17 | Refurb.Cli 18 | Refurb.MigrationUtils 19 | Refurb.Run.Backup 20 | Refurb.Run.Info 21 | Refurb.Run.Internal 22 | Refurb.Run.Migrate 23 | Refurb.Store 24 | Refurb.Types 25 | other-modules: 26 | Paths_refurb 27 | hs-source-dirs: 28 | src 29 | ghc-options: -Wall -O2 30 | build-depends: 31 | ansi-wl-pprint 32 | , base >=4.7 && <5 33 | , bytestring 34 | , classy-prelude 35 | , composite-base ==0.8.* 36 | , composite-opaleye ==0.8.* 37 | , dlist 38 | , exceptions 39 | , fast-logger 40 | , lens 41 | , monad-control 42 | , monad-logger 43 | , old-locale 44 | , opaleye >= 0.9.2 && <0.9.8 45 | , optparse-applicative 46 | , postgresql-simple 47 | , process 48 | , product-profunctors 49 | , template-haskell 50 | , text 51 | , these 52 | , these-lens 53 | , thyme 54 | , transformers-base 55 | , vector-space 56 | default-language: Haskell2010 57 | 58 | test-suite refurb-test 59 | type: exitcode-stdio-1.0 60 | main-is: Main.hs 61 | other-modules: 62 | MigrationUtilsSpec 63 | Paths_refurb 64 | hs-source-dirs: 65 | test 66 | ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 67 | build-depends: 68 | ansi-wl-pprint 69 | , base >=4.7 && <5 70 | , bytestring 71 | , classy-prelude 72 | , composite-base ==0.8.* 73 | , composite-opaleye ==0.8.* 74 | , dlist 75 | , exceptions 76 | , fast-logger 77 | , hspec 78 | , lens 79 | , monad-control 80 | , monad-logger 81 | , old-locale 82 | , opaleye >= 0.9.2 && <0.9.8 83 | , optparse-applicative 84 | , postgresql-simple 85 | , process 86 | , product-profunctors 87 | , refurb 88 | , template-haskell 89 | , text 90 | , these 91 | , these-lens 92 | , thyme 93 | , transformers-base 94 | , vector-space 95 | default-language: Haskell2010 96 | -------------------------------------------------------------------------------- /src/Refurb.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | -- |Top level module of Refurb along which re-exports the library portion of Refurb ('Refurb.Types' and 'Refurb.MigrationUtils') 6 | module Refurb 7 | ( refurbMain 8 | , refurbArgs 9 | , module Refurb.MigrationUtils 10 | , module Refurb.Types 11 | ) where 12 | 13 | import ClassyPrelude 14 | import Control.Monad.Base (liftBase) 15 | import Control.Monad.Logger (LogLevel(LevelDebug), filterLogger, logDebug, runStdoutLoggingT) 16 | import qualified Database.PostgreSQL.Simple as PG 17 | import qualified Options.Applicative as OA 18 | import Refurb.Cli (Command(CommandMigrate, CommandShowLog, CommandShowMigration, CommandBackup), ConnectOps(ConnectOpsFile, ConnectOpsParams), Opts(Opts, debug, command, config), optsParser) 19 | import Refurb.MigrationUtils 20 | import Refurb.Run.Backup (backup) 21 | import Refurb.Run.Internal (Context(Context)) 22 | import Refurb.Run.Info (showMigration, showLog) 23 | import Refurb.Run.Migrate (migrate) 24 | import Refurb.Store (isSchemaPresent, initializeSchema) 25 | import Refurb.Types 26 | import System.Environment (lookupEnv) 27 | 28 | -- |Main entry point for refurbishing. 29 | -- 30 | -- In @refurb readDatabaseConnectionString migrations@, @readDatabaseConnectionString@ is a function taking the configuration file path from the command line 31 | -- and yielding a pair of actual and loggable connection strings, and @migrations@ is a list of 'Migration' records to consider. 32 | -- 33 | -- For example: 34 | -- 35 | -- @ 36 | -- module Main where 37 | -- 38 | -- import Refurb ('Migration', 'MonadMigration', 'execute_', 'schemaMigration', refurbMain) 39 | -- 40 | -- migrations :: ['Migration'] 41 | -- migrations = 42 | -- [ schemaMigration "create-my-table" createMyTable 43 | -- ] 44 | -- 45 | -- createMyTable :: MonadMigration m => m () 46 | -- createMyTable = 47 | -- void $ execute_ "create table my_table (...)" 48 | -- 49 | -- main :: IO () 50 | -- main = refurbMain readDatabaseConnectInfo migrations 51 | -- @ 52 | refurbMain :: (FilePath -> IO PG.ConnectInfo) -> [Migration] -> IO () 53 | refurbMain readConnectInfo migrations = do 54 | opts@(Opts {..}) <- OA.execParser optsParser 55 | connectInfo <- case config of 56 | ConnectOpsFile file -> readConnectInfo file 57 | ConnectOpsParams host port dbname user -> do 58 | password <- lookupEnv "PGPASS" 59 | pure PG.ConnectInfo 60 | { connectHost = host, 61 | connectPort = port, 62 | connectUser = user, 63 | connectPassword = fromMaybe "" password, 64 | connectDatabase = dbname 65 | } 66 | refurbArgs opts connectInfo migrations 67 | 68 | refurbArgs :: Opts -> PG.ConnectInfo -> [Migration] -> IO () 69 | refurbArgs opts@(Opts {..}) connectInfo migrations = do 70 | let logFilter = if debug 71 | then \ _ _ -> True 72 | else \ _ lvl -> lvl > LevelDebug 73 | 74 | runStdoutLoggingT . filterLogger logFilter $ do 75 | $logDebug $ "Connecting to " <> tshow (connectInfoAsLogString connectInfo) 76 | bracket (liftBase $ PG.connect connectInfo) (liftBase . PG.close) $ \ conn -> do 77 | let context = Context opts conn connectInfo migrations 78 | 79 | unlessM (isSchemaPresent conn) $ initializeSchema conn 80 | 81 | void . liftIO $ PG.execute_ conn "set search_path = 'public'" 82 | flip runReaderT context $ 83 | case command of 84 | CommandMigrate goNoGo backupMay installSeedData -> 85 | migrate goNoGo backupMay installSeedData 86 | CommandShowLog -> 87 | showLog 88 | CommandShowMigration key -> 89 | showMigration key 90 | CommandBackup path -> 91 | backup path 92 | -------------------------------------------------------------------------------- /src/Refurb/Cli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | -- |Module with @optparse-applicative@ parsers for and datatypes to represent the command line arguments. 3 | module Refurb.Cli where 4 | 5 | import ClassyPrelude 6 | import Composite.Record ((:->)(Val)) 7 | import Data.Word (Word16) 8 | import qualified Options.Applicative as OA 9 | import Refurb.Store (FQualifiedKey) 10 | 11 | -- |Newtype wrapper for the @--execute@ boolean (@True@ if given, @False@ if omitted) 12 | newtype GoNoGo = GoNoGo Bool deriving (Eq, Show) 13 | 14 | -- |Newtype wrapper for the @--backup-first@ option to the @migrate@ command. 15 | newtype PreMigrationBackup = PreMigrationBackup FilePath deriving (Eq, Show) 16 | 17 | -- |Newtype wrapper for the @--seed@ boolean (@True@ if given, @False@ if omitted) 18 | newtype InstallSeedData = InstallSeedData Bool deriving (Eq, Show) 19 | 20 | -- |The various top level commands that can be requested by the user 21 | data Command 22 | = CommandMigrate GoNoGo (Maybe PreMigrationBackup) InstallSeedData 23 | -- ^Migrate the database or show what migrations would be applied, possibly backing up beforehand. 24 | | CommandShowLog 25 | -- ^Show the migration status. 26 | | CommandShowMigration FQualifiedKey 27 | -- ^Show status of a particular migration with its log output. 28 | | CommandBackup FilePath 29 | -- ^Back up the database. 30 | deriving (Eq, Show) 31 | 32 | -- |Option parser for the @migrate@ command 33 | commandMigrateParser :: OA.ParserInfo Command 34 | commandMigrateParser = 35 | OA.info 36 | ( 37 | CommandMigrate 38 | <$> ( GoNoGo <$> OA.switch 39 | ( OA.long "execute" 40 | <> OA.short 'e' 41 | <> OA.help "Actually run migrations. Without this switch the migrations to run will be logged but none of them executed." 42 | ) 43 | ) 44 | <*> ( OA.option (Just . PreMigrationBackup <$> OA.auto) 45 | ( OA.value Nothing 46 | <> OA.long "backup-first" 47 | <> OA.short 'b' 48 | <> OA.metavar "BACKUP-FILE" 49 | <> OA.help "Back up the database before applying migrations. Has no effect without --execute." 50 | ) 51 | ) 52 | <*> ( InstallSeedData <$> OA.switch 53 | ( OA.long "seed" 54 | <> OA.short 's' 55 | <> OA.help "Apply seed scripts in addition to schema migrations. Not available on prod databases." 56 | ) 57 | ) 58 | ) 59 | ( OA.progDesc "Apply migrations to the database, or see which ones would be applied" ) 60 | 61 | -- |Option parser for the @show-log@ command 62 | commandShowLogParser :: OA.ParserInfo Command 63 | commandShowLogParser = 64 | OA.info 65 | ( 66 | pure CommandShowLog 67 | ) 68 | ( OA.progDesc "Show migrations along with their status in the database" ) 69 | 70 | -- |Option parser for the @show-migration@ command 71 | commandShowMigrationParser :: OA.ParserInfo Command 72 | commandShowMigrationParser = 73 | OA.info 74 | ( 75 | CommandShowMigration 76 | <$> (Val . pack <$> OA.strArgument (OA.metavar "MIGRATION-KEY")) 77 | ) 78 | ( OA.progDesc "Show status of and log details for a particular migration" ) 79 | 80 | -- |Option parser for the @backup@ command 81 | commandBackupParser :: OA.ParserInfo Command 82 | commandBackupParser = 83 | OA.info 84 | ( 85 | CommandBackup 86 | <$> OA.strArgument (OA.metavar "BACKUP-FILE") 87 | ) 88 | ( OA.progDesc "Back up the database" ) 89 | 90 | -- |Options for connecting to database. 91 | data ConnectOps 92 | = ConnectOpsFile FilePath 93 | -- ^Connect via a file 94 | | ConnectOpsParams String Word16 String String 95 | -- ^Connect via parameters - reads password from PGPASS 96 | 97 | -- |Structure holding the parsed command line arguments and options. 98 | data Opts = Opts 99 | { debug :: Bool 100 | -- ^Whether to turn on debug logging to the console 101 | , colorize :: Bool 102 | -- ^Whether to colorize console output 103 | , config :: ConnectOps 104 | -- ^See 'ConnectOps' 105 | , command :: Command 106 | -- ^Which command the user chose and the options for that command 107 | } 108 | 109 | connectOpsParser :: OA.Parser ConnectOps 110 | connectOpsParser = fileParser <|> paramsParser 111 | where 112 | fileParser = ConnectOpsFile 113 | <$> OA.strOption 114 | ( OA.long "config" 115 | <> OA.short 'c' 116 | <> OA.metavar "SERVER-CONFIG" 117 | <> OA.help "Path to server config file to read database connection information from" 118 | ) 119 | paramsParser = ConnectOpsParams 120 | <$> OA.strOption 121 | ( OA.long "host" 122 | <> OA.metavar "DATABASE-HOST" 123 | <> OA.value "localhost" 124 | <> OA.help "Database host" 125 | <> OA.showDefault 126 | ) 127 | <*> OA.option OA.auto 128 | ( OA.long "port" 129 | <> OA.metavar "DATABASE-PORT" 130 | <> OA.value 5432 131 | <> OA.help "Database port" 132 | <> OA.showDefault 133 | ) 134 | <*> OA.strOption 135 | ( OA.long "dbname" 136 | <> OA.metavar "DATABASE-NAME" 137 | <> OA.value "postgres" 138 | <> OA.help "Database name" 139 | <> OA.showDefault 140 | ) 141 | <*> OA.strOption 142 | ( OA.long "user" 143 | <> OA.metavar "DATABASE-USER" 144 | <> OA.value "postgres" 145 | <> OA.help "Database user" 146 | <> OA.showDefault 147 | ) 148 | 149 | 150 | -- |Parser for the command line arguments 151 | optsParser :: OA.ParserInfo Opts 152 | optsParser = 153 | OA.info 154 | ( 155 | OA.helper <*> ( 156 | Opts 157 | <$> OA.switch 158 | ( OA.long "debug" 159 | <> OA.short 'd' 160 | <> OA.help "Turn on debug diagnostic logging" 161 | ) 162 | <*> (not <$> OA.switch (OA.long "no-color" <> OA.help "disable ANSI colorization")) 163 | <*> connectOpsParser 164 | <*> OA.hsubparser 165 | ( OA.command "migrate" commandMigrateParser 166 | <> OA.command "show-log" commandShowLogParser 167 | <> OA.command "show-migration" commandShowMigrationParser 168 | <> OA.command "backup" commandBackupParser 169 | ) 170 | ) 171 | ) 172 | ( OA.fullDesc 173 | <> OA.header "Maintain server database" 174 | ) 175 | -------------------------------------------------------------------------------- /src/Refurb/MigrationUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | -- |Utilities for writing migrations. 7 | module Refurb.MigrationUtils where 8 | 9 | import ClassyPrelude 10 | import Control.Monad.Base (liftBase) 11 | import Control.Monad.Logger (logDebug) 12 | import Data.Profunctor.Product.Default (Default) 13 | import qualified Data.Text as T 14 | import qualified Database.PostgreSQL.Simple as PG 15 | import Database.PostgreSQL.Simple.ToRow (toRow) 16 | import Database.PostgreSQL.Simple.Types (fromQuery) 17 | import qualified Language.Haskell.TH.Syntax as TH 18 | import qualified Language.Haskell.TH.Quote as TH 19 | import qualified Opaleye 20 | import Opaleye.Internal.Table (tableIdentifier) 21 | import Refurb.Types (MonadMigration) 22 | 23 | -- |Simple quasiquoter which just makes it easier to embed literal chunks of SQL in migrations. 24 | -- 25 | -- For example: 26 | -- 27 | -- @ 28 | -- createStuffIndex :: MonadMigration m => m () 29 | -- createStuffIndex = 30 | -- execute_ 31 | -- [qqSql| 32 | -- create index stuff_index 33 | -- on stuff (things) 34 | -- where is_what_we_want_to_index = 't' 35 | -- |] 36 | -- @ 37 | qqSql :: TH.QuasiQuoter 38 | qqSql = TH.QuasiQuoter 39 | { TH.quoteExp = \ s -> [| $(TH.lift s) :: PG.Query |] 40 | , TH.quotePat = error "qqSql should only be used in an expression context" 41 | , TH.quoteType = error "qqSql should only be used in an expression context" 42 | , TH.quoteDec = error "qqSql should only be used in an expression context" 43 | } 44 | 45 | -- |Quasiquoter which takes a block of literal SQL and converts it into a list of 'PG.Query' values, e.g. to pass to 'executeSeries_'. A semicolon at the 46 | -- beginning or end of a line (sans whitespace) separates SQL statements. 47 | -- 48 | -- For example: 49 | -- 50 | -- @ 51 | -- createStuff :: MonadMigration m => m () 52 | -- createStuff = 53 | -- executeSeries_ [qqSqls| 54 | -- create sequence stuff_seq; 55 | -- create table stuff 56 | -- ( id bigint not null primary key default nextval('stuff_seq') 57 | -- ); 58 | -- |] 59 | -- @ 60 | qqSqls :: TH.QuasiQuoter 61 | qqSqls = TH.QuasiQuoter 62 | { TH.quoteExp = \ s -> [| $(bodyToStatements s) :: [PG.Query] |] 63 | , TH.quotePat = error "qqSql should only be used in an expression context" 64 | , TH.quoteType = error "qqSql should only be used in an expression context" 65 | , TH.quoteDec = error "qqSql should only be used in an expression context" 66 | } 67 | where 68 | bodyToStatements :: String -> TH.Q TH.Exp 69 | bodyToStatements = TH.lift . map (unpack . unlines) . filter (not . null) . map (filter (not . null)) . go [] . lines . pack 70 | where 71 | go acc [] = [acc] 72 | go acc ((T.strip -> l):ls) 73 | | Just l' <- T.stripSuffix ";" =<< T.stripPrefix ";" l = 74 | reverse acc : [l'] : go [] ls 75 | | Just l' <- T.stripPrefix ";" l = 76 | reverse acc : go [l'] ls 77 | | Just l' <- T.stripSuffix ";" l = 78 | reverse (l' : acc) : go [] ls 79 | | otherwise = 80 | go (l : acc) ls 81 | 82 | -- |Execute some parameterized SQL against the database connection. 83 | -- Wraps 'PG.execute' using the 'MonadMigration' reader to get the connection. 84 | execute :: (MonadMigration m, PG.ToRow q) => PG.Query -> q -> m Int64 85 | execute q p = do 86 | conn <- ask 87 | $logDebug $ decodeUtf8 (fromQuery q) <> " with " <> tshow (toRow p) 88 | liftBase $ PG.execute conn q p 89 | 90 | -- |Execute some parameterized SQL against the database connection. 91 | -- Wraps 'PG.executeMany' using the 'MonadMigration' reader to get the connection. 92 | executeMany :: (MonadMigration m, PG.ToRow q) => PG.Query -> [q] -> m Int64 93 | executeMany q ps = do 94 | conn <- ask 95 | $logDebug $ decodeUtf8 (fromQuery q) <> " with [" 96 | <> maybe "" ((if length ps > 1 then (<> ", ...") else id) . tshow . toRow) (headMay ps) <> "]" 97 | liftBase $ PG.executeMany conn q ps 98 | 99 | -- |Execute some fixed SQL against the database connection. 100 | -- Wraps 'PG.execute_' using the 'MonadMigration' reader to get the connection. 101 | execute_ :: MonadMigration m => PG.Query -> m Int64 102 | execute_ q = do 103 | conn <- ask 104 | $logDebug . decodeUtf8 $ fromQuery q 105 | liftBase $ PG.execute_ conn q 106 | 107 | -- |Execute a series of fixed SQL statements against the database connection. 108 | -- Equivalent to `traverse_ (void . execute_)` 109 | executeSeries_ :: MonadMigration m => [PG.Query] -> m () 110 | executeSeries_ = traverse_ (void . execute_) 111 | 112 | -- |Run a parameterized query against the database connection. 113 | -- Wraps 'PG.query' using the 'MonadMigration' reader to get the connection. 114 | query :: (MonadMigration m, PG.ToRow q, PG.FromRow r) => PG.Query -> q -> m [r] 115 | query q p = do 116 | conn <- ask 117 | $logDebug $ decodeUtf8 (fromQuery q) <> " with " <> tshow (toRow p) 118 | liftBase $ PG.query conn q p 119 | 120 | -- |Run a fixed query against the database connection. 121 | -- Wraps 'PG.query_' using the 'MonadMigration' reader to get the connection. 122 | query_ :: (MonadMigration m, PG.FromRow r) => PG.Query -> m [r] 123 | query_ q = do 124 | conn <- ask 125 | $logDebug . decodeUtf8 $ fromQuery q 126 | liftBase $ PG.query_ conn q 127 | 128 | -- |Run an Opaleye query against the database connection. 129 | -- Wraps 'Opaleye.runSelect' using the 'MonadMigration' reader to get the connection. 130 | runQuery 131 | :: ( MonadMigration m 132 | , Default Opaleye.Unpackspec columns columns 133 | , Default Opaleye.FromFields columns haskells 134 | ) 135 | => Opaleye.Select columns -> m [haskells] 136 | runQuery q = do 137 | conn <- ask 138 | for_ (Opaleye.showSql q) ($logDebug . pack) 139 | liftBase $ Opaleye.runSelect conn q 140 | 141 | -- |Run an Opaleye 'Opaleye.runInsert' against the database connection. 142 | runInsertMany :: MonadMigration m => Opaleye.Table columns columns' -> [columns] -> m Int64 143 | runInsertMany table rows = do 144 | conn <- ask 145 | $logDebug $ "inserting " <> tshow (length rows) <> " rows into " <> tshow (tableIdentifier table) 146 | liftBase $ Opaleye.runInsert conn (Opaleye.Insert table rows Opaleye.rCount Nothing) 147 | 148 | -- |Run an Opaleye 'Opaleye.runUpdate' against the database connection. 149 | runUpdate :: MonadMigration m => Opaleye.Table columnsW columnsR -> (columnsR -> columnsW) -> (columnsR -> Opaleye.Field Opaleye.SqlBool) -> m Int64 150 | runUpdate table permute filt = do 151 | conn <- ask 152 | $logDebug $ "updating " <> tshow (tableIdentifier table) 153 | liftBase $ Opaleye.runUpdate conn (Opaleye.Update table permute filt Opaleye.rCount) 154 | 155 | -- |Run an Opaleye 'Opaleye.runDelete' against the database connection. 156 | runDelete :: MonadMigration m => Opaleye.Table columnsW columnsR -> (columnsR -> Opaleye.Field Opaleye.SqlBool) -> m Int64 157 | runDelete table filt = do 158 | conn <- ask 159 | $logDebug $ "deleting from " <> tshow (tableIdentifier table) 160 | liftBase $ Opaleye.runDelete conn (Opaleye.Delete table filt Opaleye.rCount) 161 | 162 | -- |Check if a schema exists using the @information_schema@ views. 163 | doesSchemaExist :: MonadMigration m => Text -> m Bool 164 | doesSchemaExist schema = 165 | not . (null :: [PG.Only Int] -> Bool) <$> query "select 1 from information_schema.schemata where schema_name = ?" (PG.Only schema) 166 | 167 | -- |Check if a table exists in a schema using the @information_schema@ views. 168 | doesTableExist :: MonadMigration m => Text -> Text -> m Bool 169 | doesTableExist schema table = 170 | not . (null :: [PG.Only Int] -> Bool) <$> query "select 1 from information_schema.tables where table_schema = ? and table_name = ?" (schema, table) 171 | 172 | -- |Check if a column exists in a schema on a table using the @information_schema@ views. 173 | doesColumnExist :: MonadMigration m => Text -> Text -> Text -> m Bool 174 | doesColumnExist schema table column = 175 | not . (null :: [PG.Only Int] -> Bool) <$> query "select 1 from information_schema.columns where table_schema = ? and table_name = ? and column_name = ?" (schema, table, column) 176 | -------------------------------------------------------------------------------- /src/Refurb/Run/Backup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Refurb.Run.Backup where 6 | 7 | import ClassyPrelude 8 | import Control.Monad.Base (liftBase) 9 | import Control.Monad.Logger (logInfo, logError) 10 | import qualified Database.PostgreSQL.Simple as PG 11 | import Refurb.Run.Internal (MonadRefurb, contextDbConnectInfo) 12 | import System.Environment (getEnvironment) 13 | import System.Exit (ExitCode(ExitSuccess, ExitFailure)) 14 | import qualified System.Process as Proc 15 | 16 | -- |Handle the @backup@ command by calling @pg_dump@ to save a database backup. 17 | backup :: MonadRefurb m => FilePath -> m () 18 | backup path = do 19 | PG.ConnectInfo {..} <- asks contextDbConnectInfo 20 | $logInfo $ "Backing up database to " <> tshow path 21 | env <- liftBase getEnvironment 22 | let createProcess = 23 | ( Proc.proc "pg_dump" 24 | [ "-Z", "9" -- max compression 25 | , "-F", "c" -- "custom" format - custom to pg_dump / pg_restore 26 | , "-f", path 27 | , "-d", connectDatabase 28 | , "-U", connectUser 29 | , "-h", connectHost 30 | , "-p", show connectPort 31 | ] 32 | ) { Proc.env = Just $ ("PGPASS", connectPassword) : env } 33 | 34 | (exitCode, out, err) <- liftBase $ Proc.readCreateProcessWithExitCode createProcess "" 35 | 36 | case exitCode of 37 | ExitSuccess -> 38 | $logInfo "Backup complete." 39 | ExitFailure code -> do 40 | $logError $ "Backup failed with code " <> tshow code 41 | $logError $ "pg_dump stdout:\n" <> pack out 42 | $logError $ "pg_dump stderr:\n" <> pack err 43 | fail "pg_dump failed" 44 | -------------------------------------------------------------------------------- /src/Refurb/Run/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ViewPatterns #-} 9 | module Refurb.Run.Info where 10 | 11 | import ClassyPrelude 12 | import Composite.Record (Record) 13 | import Control.Arrow (returnA) 14 | import Control.Lens (Getting, _Wrapped, each, preview, to, view) 15 | import Data.Monoid (First) 16 | #if MIN_VERSION_these(1,0,0) 17 | import Data.These (These(This, That, These)) 18 | import Data.These.Lens (there) 19 | #else 20 | import Data.These (These(This, That, These), there) 21 | #endif 22 | import Data.Thyme.Clock (NominalDiffTime, fromSeconds) 23 | import Data.Thyme.Format.Human (humanTimeDiff) 24 | import Opaleye ((.==), restrict, toFields) 25 | import Refurb.Run.Internal (MonadRefurb, contextDbConn, contextMigrations, optionallyColoredM, migrationResultDoc) 26 | import Refurb.Store (FQualifiedKey, MigrationLog, cQualifiedKey, fId, fApplied, fDuration, fOutput, fResult, fQualifiedKey, readMigrationStatus) 27 | import Refurb.Types (Migration, MigrationType(MigrationSeedData), migrationQualifiedKey, migrationType) 28 | import Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), fill, bold, underline, black, red, white, parens, text) 29 | 30 | -- |Given a migration status as read by 'readMigrationStatus', pretty print that information as a table on stdout. 31 | showMigrationStatus :: (MonadRefurb m, MonoTraversable t, Element t ~ These Migration (Record MigrationLog)) => t -> m () 32 | showMigrationStatus migrationStatus = do 33 | disp <- optionallyColoredM 34 | disp . bold . underline $ row (text "ID") (text "Timestamp") (text "Duration") (text "Result") (text "Key") 35 | for_ migrationStatus $ \ these -> 36 | disp $ case these of 37 | These m mlog -> mlogRow mlog <+> seedDoc m 38 | This m -> row (text "") (text "not applied") (text "") (text "") (white . text . unpack $ migrationQualifiedKey m) <+> seedDoc m 39 | That mlog -> mlogRow mlog <+> parens (red "not in known migrations") 40 | 41 | where 42 | row :: Doc -> Doc -> Doc -> Doc -> Doc -> Doc 43 | row i t d r k = fill 6 i <+> fill 19 t <+> fill 15 d <+> fill 7 r <+> k 44 | 45 | field :: Getting (First String) s String -> s -> Doc 46 | field f = text . fromMaybe "" . preview f 47 | 48 | seedDoc :: Migration -> Doc 49 | seedDoc (view migrationType -> mtype) 50 | | mtype == MigrationSeedData = text "(seed data)" 51 | | otherwise = mempty 52 | 53 | mlogRow :: Record MigrationLog -> Doc 54 | mlogRow = 55 | row 56 | <$> field (fId . to show) 57 | <*> view (fApplied . to (white . text . formatTime defaultTimeLocale "%F %T")) 58 | <*> field (fDuration . to (humanTimeDiff . (fromSeconds :: Double -> NominalDiffTime))) 59 | <*> view (fResult . to migrationResultDoc) 60 | <*> view (fQualifiedKey . to (white . text . unpack)) 61 | 62 | -- |Implement the @show-log@ command by reading the entire migration log and displaying it with 'showMigrationStatus'. 63 | showLog :: MonadRefurb m => m () 64 | showLog = do 65 | dbConn <- asks contextDbConn 66 | migrations <- asks contextMigrations 67 | migrationStatus <- readMigrationStatus dbConn migrations (proc _ -> returnA -< ()) 68 | showMigrationStatus migrationStatus 69 | 70 | -- |Implement the @show-migration@ command by reading migration log pertaining to the given migration key and displaying it with 'showMigrationStatus' plus 71 | -- its log output. 72 | showMigration :: MonadRefurb m => FQualifiedKey -> m () 73 | showMigration (view _Wrapped -> key) = do 74 | disp <- optionallyColoredM 75 | dbConn <- asks contextDbConn 76 | migrations <- asks $ filter ((== key) . migrationQualifiedKey) . contextMigrations 77 | migrationStatus <- readMigrationStatus dbConn migrations $ proc mlog -> 78 | restrict -< view cQualifiedKey mlog .== toFields key 79 | 80 | showMigrationStatus migrationStatus 81 | putStrLn "" 82 | case preview (each . there) migrationStatus of 83 | Nothing -> disp . black $ "Never been run." -- n.b.: black is not black 84 | Just mlog -> putStrLn . view fOutput $ mlog 85 | -------------------------------------------------------------------------------- /src/Refurb/Run/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | -- |Module containing shared types and functions used for implementing the various commands. 7 | module Refurb.Run.Internal where 8 | 9 | import ClassyPrelude 10 | import Control.Monad (MonadFail) 11 | import Control.Monad.Base (liftBase) 12 | import Control.Monad.Catch (MonadMask) 13 | import Control.Monad.Logger (MonadLogger, MonadLoggerIO) 14 | import Control.Monad.Trans.Control (MonadBaseControl) 15 | import qualified Database.PostgreSQL.Simple as PG 16 | import Refurb.Cli (Opts, colorize) 17 | import Refurb.Store (MigrationResult(MigrationSuccess, MigrationFailure)) 18 | import Refurb.Types (Migration) 19 | import Text.PrettyPrint.ANSI.Leijen (Doc, green, red, plain, text, putDoc) 20 | 21 | -- |Reader context for all command execution which contains the command line options, database connection and connection information, and known migrations. 22 | data Context = Context 23 | { contextOptions :: Opts 24 | -- ^The 'Opts' structure parsed from the command line by @Refurb.Cli@. 25 | , contextDbConn :: PG.Connection 26 | -- ^The open database 'PG.Connection'. 27 | , contextDbConnectInfo :: PG.ConnectInfo 28 | -- ^The information used to connect to the database, required for running command line tools like @pg_dump@ against the same database. 29 | , contextMigrations :: [Migration] 30 | -- ^The known migrations passed in to 'Refurb.refurbMain'. 31 | } 32 | 33 | -- |Constraint of actions for command execution, including access to the 'Context', logging, and underlying IO. 34 | type MonadRefurb m = (MonadBaseControl IO m, MonadFail m, MonadMask m, MonadReader Context m, MonadLogger m, MonadLoggerIO m) 35 | 36 | -- |Given the configuration implicitly available to 'MonadRefurb', produce a function which possibly strips ANSI colorization from a 'Doc' if the user 37 | -- requested colorless output. 38 | optionallyColorM :: MonadRefurb m => m (Doc -> Doc) 39 | optionallyColorM = 40 | bool plain id <$> asks (colorize . contextOptions) 41 | 42 | -- |Given the configuration implicitly available to 'MonadRefurb', produce a function which emits a 'Doc' on stdout that is colored unless the user requested 43 | -- colorless output. 44 | optionallyColoredM :: MonadRefurb m => m (Doc -> m ()) 45 | optionallyColoredM = do 46 | maybePlain <- optionallyColorM 47 | pure $ \ doc -> do 48 | liftBase $ putDoc (maybePlain doc) 49 | putStrLn "" 50 | 51 | -- |Produce a colorized 'Doc' with @success@ or @failure@, based on which 'MigrationResult' value was passed. 52 | migrationResultDoc :: MigrationResult -> Doc 53 | migrationResultDoc = \ case 54 | MigrationSuccess -> green (text "success") 55 | MigrationFailure -> red (text "failure") 56 | -------------------------------------------------------------------------------- /src/Refurb/Run/Migrate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | module Refurb.Run.Migrate where 8 | 9 | import ClassyPrelude hiding ((), defaultTimeLocale, getCurrentTime, formatTime) 10 | import Composite.Record (Record, pattern (:*:), pattern RNil) 11 | import Control.Arrow (returnA) 12 | import Control.Monad.Base (liftBase) 13 | import Control.Monad.Logger (askLoggerIO, runLoggingT) 14 | import Control.Lens (each, toListOf, view) 15 | import Data.AffineSpace ((.-.)) 16 | import qualified Data.DList as DL 17 | #if MIN_VERSION_these(1,0,0) 18 | import Data.These.Lens (_This) 19 | #else 20 | import Data.These (_This) 21 | #endif 22 | import Data.Thyme.Clock (NominalDiffTime, getCurrentTime, toSeconds) 23 | import Data.Thyme.Format (defaultTimeLocale, formatTime) 24 | import Data.Thyme.Format.Human (humanTimeDiff) 25 | import Data.Thyme.Time.Core (fromThyme) 26 | import qualified Database.PostgreSQL.Simple as PG 27 | import qualified Database.PostgreSQL.Simple.Types as PG 28 | import Language.Haskell.TH (Loc, loc_package, loc_module, loc_filename, loc_start) 29 | import Opaleye (Insert (Insert), rCount, runInsert, toFields) 30 | import Refurb.Cli (GoNoGo(GoNoGo), PreMigrationBackup(PreMigrationBackup), InstallSeedData(InstallSeedData)) 31 | import Refurb.MigrationUtils (doesSchemaExist) 32 | import Refurb.Run.Backup (backup) 33 | import Refurb.Run.Internal (MonadRefurb, contextDbConn, contextMigrations, optionallyColoredM) 34 | import Refurb.Store (MigrationLogW, MigrationLogColsW, MigrationResult(MigrationSuccess, MigrationFailure), migrationLog, isProdSystem, readMigrationStatus) 35 | import Refurb.Types (Migration, migrationQualifiedKey, migrationSchema, migrationType, migrationCheck, migrationExecute, MigrationType(MigrationSchema)) 36 | import System.Exit (exitFailure) 37 | import System.Log.FastLogger (LogStr, fromLogStr, toLogStr) 38 | import Text.PrettyPrint.ANSI.Leijen (Doc, (), (<+>), hang, fillSep, red, green, white, text) 39 | 40 | -- |Helper which produces the standard prefix 'Doc' for a given migration: @migration key: @ with color. 41 | migrationPrefixDoc :: Migration -> Doc 42 | migrationPrefixDoc migration = white (text . unpack . migrationQualifiedKey $ migration) ++ text ":" 43 | 44 | -- |Implement the @migrate@ command by verifying that seed data is only applied to non-production databases, reading the migration status, and determining 45 | -- from that status which migrations to apply. If the user requested execution of migrations, delegate to 'applyMigrations' to actually do the work. 46 | migrate :: (MonadUnliftIO m, MonadRefurb m) => GoNoGo -> Maybe PreMigrationBackup -> InstallSeedData -> m () 47 | migrate (GoNoGo isGo) backupMay (InstallSeedData shouldInstallSeedData) = do 48 | disp <- optionallyColoredM 49 | dbConn <- asks contextDbConn 50 | migrations <- asks contextMigrations 51 | 52 | when shouldInstallSeedData $ 53 | whenM (isProdSystem dbConn) $ do 54 | disp . red . text $ "Refusing to install seed data on production system." 55 | liftBase exitFailure 56 | 57 | migrationStatus <- readMigrationStatus dbConn (filter useMigration migrations) (proc _ -> returnA -< ()) 58 | 59 | let migrationsToApply = toListOf (each . _This) migrationStatus 60 | disp . hang 2 $ "Migrations to apply: " fillSep (map ((++ text ",") . white . text . unpack . migrationQualifiedKey) migrationsToApply) 61 | 62 | if isGo 63 | then traverse_ (\ (PreMigrationBackup path) -> backup path) backupMay >> applyMigrations migrationsToApply 64 | else disp $ text "Not applying migrations without --execute" 65 | 66 | where 67 | useMigration m = view migrationType m == MigrationSchema || shouldInstallSeedData 68 | 69 | -- |Given a pre-vetted list of 'Migration' structures to apply to the database, iterate through them and run their check actions (if any) followed by 70 | -- execution actions with log output captured. 71 | applyMigrations :: (MonadUnliftIO m, MonadRefurb m) => [Migration] -> m () 72 | applyMigrations migrations = do 73 | disp <- optionallyColoredM 74 | dbConn <- asks contextDbConn 75 | 76 | for_ migrations $ \ migration -> do 77 | let schema = view migrationSchema migration 78 | unlessM (runReaderT (doesSchemaExist schema) dbConn) $ 79 | void . liftIO $ PG.execute_ dbConn (PG.Query $ "create schema " <> encodeUtf8 schema) 80 | 81 | void . liftIO $ PG.execute dbConn "set search_path = ?" (PG.Only $ view migrationSchema migration) 82 | 83 | for_ (view migrationCheck migration) $ \ check -> 84 | onException 85 | ( do runReaderT check dbConn 86 | disp $ migrationPrefixDoc migration <+> green (text "check passed") ) 87 | ( disp $ migrationPrefixDoc migration <+> red (text "check failed") ) 88 | 89 | outputRef <- liftBase $ newIORef (mempty :: DList ByteString) 90 | start <- liftBase getCurrentTime 91 | 92 | let insertLog result = do 93 | end <- liftBase getCurrentTime 94 | output <- decodeUtf8 . concat . intersperse "\n" <$> liftBase (readIORef outputRef) 95 | let duration = end .-. start 96 | suffix = text "after" <+> text (humanTimeDiff duration) 97 | 98 | case result of 99 | MigrationSuccess -> disp $ migrationPrefixDoc migration <+> green (text "success") <+> suffix 100 | MigrationFailure -> do disp $ migrationPrefixDoc migration <+> red (text "failure") <+> suffix 101 | putStrLn output 102 | 103 | void . liftIO $ PG.execute_ dbConn "set search_path = 'public'" 104 | liftIO . runInsert dbConn . (\rows -> Insert migrationLog rows rCount Nothing) . singleton . (toFields :: Record MigrationLogW -> Record MigrationLogColsW) $ 105 | Nothing :*: migrationQualifiedKey migration :*: fromThyme start :*: output :*: result :*: (toSeconds :: NominalDiffTime -> Double) duration :*: RNil 106 | 107 | onException 108 | ( do 109 | logFunc <- askLoggerIO 110 | runLoggingT (runReaderT (view migrationExecute migration) dbConn) $ \ loc src lvl str -> do 111 | logFunc loc src lvl str 112 | dateLogStr <- nowLogString 113 | let message = fromLogStr $ dateLogStr <> " [" <> (toLogStr . show) lvl <> "] " <> str <> " @(" <> locLogString loc <> ")" 114 | modifyIORef' outputRef (`DL.snoc` message) 115 | insertLog MigrationSuccess ) 116 | ( insertLog MigrationFailure ) 117 | 118 | -- |Format a 'Loc' in the way we want for logging output - @package:module filename:line:column@ 119 | locLogString :: Loc -> LogStr 120 | locLogString loc = p <> ":" <> m <> " " <> f <> ":" <> l <> ":" <> c 121 | where p = toLogStr . loc_package $ loc 122 | m = toLogStr . loc_module $ loc 123 | f = toLogStr . loc_filename $ loc 124 | l = toLogStr . show . fst . loc_start $ loc 125 | c = toLogStr . show . snd . loc_start $ loc 126 | 127 | -- |Format the current timestamp in the way we want for logging output - @yyyy-mm-dd hh:mm:ss.SSS@ 128 | nowLogString :: IO LogStr 129 | nowLogString = do 130 | now <- getCurrentTime 131 | pure . toLogStr $ formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now 132 | -------------------------------------------------------------------------------- /src/Refurb/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE ViewPatterns #-} 12 | -- |Module containing definition of and functions for maintaining the in-database state storage for Refurb. 13 | module Refurb.Store where 14 | 15 | import ClassyPrelude 16 | import Composite.Opaleye (defaultRecTable) 17 | import Composite.Opaleye.TH (deriveOpaleyeEnum) 18 | import Composite.Record ((:->), Record) 19 | import Composite.TH (withLensesAndProxies) 20 | import Control.Arrow (returnA) 21 | import Control.Lens (view) 22 | import Control.Monad.Base (liftBase) 23 | import Control.Monad.Catch (MonadMask) 24 | import Control.Monad.Logger (MonadLogger, logDebug) 25 | import Control.Monad.Trans.Control (MonadBaseControl) 26 | import Data.These (These(This, These, That)) 27 | import qualified Database.PostgreSQL.Simple as PG 28 | import Opaleye (Field, SelectArr, SqlBool, SqlInt4, SqlFloat8, SqlText, SqlTimestamptz, Table, asc, orderBy, runSelect, selectTable, tableWithSchema) 29 | import Refurb.MigrationUtils (doesTableExist, qqSqls) 30 | import Refurb.Types (Migration, migrationQualifiedKey) 31 | 32 | -- |Result of running a migration, either success or failure. 33 | data MigrationResult 34 | = MigrationSuccess 35 | | MigrationFailure 36 | deriving (Eq, Show) 37 | 38 | deriveOpaleyeEnum ''MigrationResult "refurb.migration_result_enum" (stripPrefix "migration" . toLower) 39 | 40 | withLensesAndProxies [d| 41 | type FId = "id" :-> Int32 42 | type FIdMay = "id" :-> Maybe Int32 43 | type CId = "id" :-> Field SqlInt4 44 | type CIdMay = "id" :-> Maybe (Field SqlInt4) 45 | type FQualifiedKey = "qualified_key" :-> Text 46 | type CQualifiedKey = "qualified_key" :-> Field SqlText 47 | type FApplied = "applied" :-> UTCTime 48 | type CApplied = "applied" :-> Field SqlTimestamptz 49 | type FOutput = "output" :-> Text 50 | type COutput = "output" :-> Field SqlText 51 | type FResult = "result" :-> MigrationResult 52 | type CResult = "result" :-> Field PGMigrationResult 53 | type FDuration = "duration" :-> Double 54 | type CDuration = "duration" :-> Field SqlFloat8 55 | 56 | type FProdSystem = "prod_system" :-> Bool 57 | type CProdSystem = "prod_system" :-> Field SqlBool 58 | |] 59 | 60 | -- |Fields of a migration log entry in memory fetched from the database (with ID) 61 | type MigrationLog = '[FId , FQualifiedKey, FApplied, FOutput, FResult, FDuration] 62 | -- |Fields of a migration log entry to insert in the database (with the ID column optional) 63 | type MigrationLogW = '[FIdMay, FQualifiedKey, FApplied, FOutput, FResult, FDuration] 64 | -- |Columns of a migration log when reading from the database (with ID) 65 | type MigrationLogColsR = '[CId , CQualifiedKey, CApplied, COutput, CResult, CDuration] 66 | -- |Columns of a migration log when inserting into the database (with ID column optional) 67 | type MigrationLogColsW = '[CIdMay, CQualifiedKey, CApplied, COutput, CResult, CDuration] 68 | 69 | -- |Fields of the Refurb config in memory 70 | type RefurbConfig = '[FProdSystem] 71 | -- |Columns of the Refurb config in the database 72 | type RefurbConfigCols = '[CProdSystem] 73 | 74 | -- |The migration log table which records all executed migrations and their results 75 | migrationLog :: Table (Record MigrationLogColsW) (Record MigrationLogColsR) 76 | migrationLog = tableWithSchema "refurb" "migration_log" defaultRecTable 77 | 78 | -- |The refurb config table which controls whether this database is considered a production one or not 79 | refurbConfig :: Table (Record RefurbConfigCols) (Record RefurbConfigCols) 80 | refurbConfig = tableWithSchema "refurb" "config" defaultRecTable 81 | 82 | -- |Test to see if the schema seems to be installed by looking for an existing refurb_config table 83 | isSchemaPresent :: (MonadBaseControl IO m, MonadMask m, MonadLogger m) => PG.Connection -> m Bool 84 | isSchemaPresent conn = do 85 | $logDebug "Checking if schema present" 86 | runReaderT (doesTableExist "refurb" "config") conn 87 | 88 | -- |Check if this database is configured as a production database by reading the refurb config table 89 | isProdSystem :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m Bool 90 | isProdSystem conn = do 91 | $logDebug "Checking if this is a prod system" 92 | map (fromMaybe False . headMay) . liftBase . runSelect conn $ proc () -> do 93 | config <- selectTable refurbConfig -< () 94 | returnA -< view cProdSystem config 95 | 96 | -- |Create the refurb schema elements. Will fail if they already exist. 97 | initializeSchema :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m () 98 | initializeSchema conn = do 99 | $logDebug "Initializing refurb schema" 100 | 101 | liftBase $ traverse_ (void . PG.execute_ conn) [qqSqls| 102 | create schema refurb; 103 | set search_path = 'refurb'; 104 | create type migration_result_enum as enum('success', 'failure'); 105 | create table config (prod_system boolean not null); 106 | insert into config (prod_system) values (false); 107 | create sequence migration_log_serial; 108 | create table migration_log 109 | ( id int not null 110 | primary key 111 | default nextval('migration_log_serial') 112 | , qualified_key text not null 113 | unique 114 | , applied timestamptz not null 115 | , output text not null 116 | , result migration_result_enum not null 117 | , duration double precision not null 118 | ); 119 | |] 120 | 121 | -- |Read the migration log and stitch it together with the expected migration list, forming a list in the same order as the known migrations but with 122 | -- 'These' representing whether the migration log for the known migration is present or not. 123 | -- 124 | -- * @'This' migration@ represents a known migration that has no log entry. 125 | -- * @'That' migrationLog@ represents an unknown migration that was applied in the past. 126 | -- * @'These' migration migrationLog@ represents a migration that has an attempted application in the log. 127 | readMigrationStatus 128 | :: (MonadBaseControl IO m, MonadLogger m) 129 | => PG.Connection 130 | -> [Migration] 131 | -> SelectArr (Record MigrationLogColsR) () 132 | -> m [These Migration (Record MigrationLog)] 133 | readMigrationStatus conn migrations restriction = do 134 | $logDebug "Reading migration status" 135 | migrationStatus <- liftBase $ runSelect conn . orderBy (asc $ view cQualifiedKey) $ proc () -> do 136 | mlog <- selectTable migrationLog -< () 137 | restriction -< mlog 138 | returnA -< mlog 139 | 140 | let migrationLogByKey = mapFromList . map (view fQualifiedKey &&& id) $ migrationStatus 141 | 142 | alignMigration 143 | :: Migration 144 | -> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog)) 145 | -> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog)) 146 | alignMigration m@(migrationQualifiedKey -> k) (t, l) = 147 | first ((:t) . maybe (This m) (These m)) (updateLookupWithKey (\ _ _ -> Nothing) k l) 148 | 149 | (aligned, extra) = foldr alignMigration ([], migrationLogByKey) migrations 150 | 151 | pure $ map That (toList extra) ++ aligned 152 | -------------------------------------------------------------------------------- /src/Refurb/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | -- |Module containing externally useful types for Refurb, most notably the 'Migration' type. 10 | module Refurb.Types 11 | ( connectInfoAsLogString 12 | , MigrationType(..) 13 | , MonadMigration 14 | , Migration(..), migrationSchema, migrationKey, migrationType, migrationCheck, migrationExecute, migrationQualifiedKey 15 | , schemaMigration, seedDataMigration, withCheck 16 | ) where 17 | 18 | import ClassyPrelude 19 | import Control.Lens.TH (makeLenses) 20 | import Control.Monad.Catch (MonadMask) 21 | import Control.Monad.Logger (MonadLogger) 22 | import Control.Monad.Trans.Control (MonadBaseControl) 23 | import qualified Database.PostgreSQL.Simple as PG 24 | 25 | -- |Omit password from 'PG.ConnectInfo' 26 | omitPassword :: PG.ConnectInfo -> PG.ConnectInfo 27 | omitPassword info = info { PG.connectPassword = "" } 28 | 29 | -- |Given a 'PG.ConnectInfo' make up the log-safe connection string to show to humans, which omits the password. 30 | connectInfoAsLogString :: PG.ConnectInfo -> Text 31 | connectInfoAsLogString = 32 | decodeUtf8 . PG.postgreSQLConnectionString . omitPassword 33 | 34 | -- |Enumeration of the types of migration that are known about. 35 | data MigrationType 36 | = MigrationSchema 37 | -- ^Migration that updates the schema of the database and should be run everywhere. 38 | | MigrationSeedData 39 | -- ^Migration that installs or replaces data for testing purposes and should never be run in production. 40 | deriving (Eq, Show) 41 | 42 | -- |Constraint for actions run in the context of a migration, with access to underlying IO, PostgreSQL connection, and logging. 43 | type MonadMigration m = (MonadBaseControl IO m, MonadMask m, MonadReader PG.Connection m, MonadLogger m) 44 | 45 | -- |Data type of a migration, with its key, type, and actions. 46 | data Migration = Migration 47 | { _migrationSchema :: Text 48 | -- ^Schema for the migration to run in, which also qualifies the migration key." 49 | , _migrationKey :: Text 50 | -- ^Unique key to identify this migration among all known migrations. Never reuse keys, as they're the only link between the stored migration log and known 51 | -- migrations. 52 | , _migrationType :: MigrationType 53 | -- ^What type of migration this is. 54 | , _migrationCheck :: forall m. MonadMigration m => Maybe (m ()) 55 | -- ^Optional action to execute before the primary execution to verify preconditions. 56 | , _migrationExecute :: forall m. MonadMigration m => m () 57 | -- ^Main migration action, such as creating tables or updating data. 58 | } 59 | 60 | -- |The fully qualified key of the migration, schema.key 61 | migrationQualifiedKey :: Migration -> Text 62 | migrationQualifiedKey (Migration { _migrationSchema, _migrationKey }) = 63 | _migrationSchema <> "." <> _migrationKey 64 | 65 | makeLenses ''Migration 66 | 67 | -- |Helper to construct a 'MigrationSchema' type 'Migration' with the given execution action and no check action. 68 | schemaMigration :: Text -> Text -> (forall m. MonadMigration m => m ()) -> Migration 69 | schemaMigration schema key execute = Migration 70 | { _migrationSchema = schema 71 | , _migrationKey = key 72 | , _migrationType = MigrationSchema 73 | , _migrationCheck = Nothing 74 | , _migrationExecute = execute 75 | } 76 | 77 | -- |Helper to construct a 'MigrationSeedData' type 'Migration' with the given execution action and no check action. 78 | seedDataMigration :: Text -> Text -> (forall m. MonadMigration m => m ()) -> Migration 79 | seedDataMigration schema key execute = Migration 80 | { _migrationSchema = schema 81 | , _migrationKey = key 82 | , _migrationType = MigrationSeedData 83 | , _migrationCheck = Nothing 84 | , _migrationExecute = execute 85 | } 86 | 87 | -- |Attach a check function to a 'Migration'. 88 | withCheck :: Migration -> (forall m. MonadMigration m => m ()) -> Migration 89 | withCheck m c = m { _migrationCheck = Just c } 90 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Main where 3 | import ClassyPrelude 4 | import MigrationUtilsSpec (migrationUtilsSuite) 5 | import Test.Hspec (hspec) 6 | 7 | main :: IO () 8 | main = hspec $ do 9 | migrationUtilsSuite 10 | 11 | -------------------------------------------------------------------------------- /test/MigrationUtilsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | module MigrationUtilsSpec where 5 | 6 | import ClassyPrelude 7 | import Refurb.MigrationUtils 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | 10 | migrationUtilsSuite :: Spec 11 | migrationUtilsSuite = 12 | describe "MigrationUtils" $ do 13 | it "can quote literal SQL" $ do 14 | [qqSql|foo|] `shouldBe` "foo" 15 | 16 | it "can quote a series of literal SQL statements" $ do 17 | [qqSqls|foo|] `shouldBe` ["foo\n"] 18 | 19 | [qqSqls| 20 | do 21 | a 22 | thing; 23 | and another thing 24 | ;this thing too 25 | ;but also this; 26 | |] `shouldBe` ["do\na\nthing\n", "and another thing\n", "this thing too\n", "but also this\n"] 27 | --------------------------------------------------------------------------------