├── .github └── workflows │ └── ci.yml ├── .gitignore ├── README.md ├── north ├── LICENSE ├── adapter │ ├── base.rkt │ ├── postgres.rkt │ └── sqlite.rkt ├── base.rkt ├── cli.rkt ├── info.rkt ├── lang │ └── reader.rkt ├── main.rkt ├── migrate.rkt ├── north.scrbl └── tool │ ├── constants.txt │ ├── keywords.txt │ ├── operators.txt │ └── syntax-color.rkt └── tests ├── issue-002 ├── .gitignore ├── fixtures │ ├── 20200820-broken.sql │ ├── 20200820-valid.sql │ ├── broken.out │ └── valid.out └── test.sh ├── issue-003 ├── .gitignore ├── fixtures │ ├── 20190825-broken.sql │ └── expected-output └── test.sh ├── postgres ├── .gitignore ├── fixtures │ ├── 01-dry-run-migrate.out │ ├── 02-force-run-migrate.out │ ├── 03-dry-run-rollback.out │ ├── 04-dry-run-rollback.out │ ├── 05-force-run-rollback.out │ ├── 06-dry-run-rollback.out │ ├── 07-force-run-rollback.out │ ├── 20190127-add-created-at-column.sql │ ├── 20190127-add-last-login-column.sql │ ├── 20190127-add-updated-at-column.sql │ └── 20190127-add-users-table.sql └── test.sh ├── run-all-tests.sh └── sqlite ├── .gitignore ├── fixtures ├── 01-dry-run-migrate.out ├── 02-force-run-migrate.out ├── 03-dry-run-rollback.out ├── 04-dry-run-rollback.out ├── 05-force-run-rollback.out ├── 06-dry-run-rollback.out ├── 07-force-run-rollback.out ├── 20190127-add-created-at-column.sql ├── 20190127-add-last-login-column.sql ├── 20190127-add-updated-at-column.sql └── 20190127-add-users-table.sql └── test.sh /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push] 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | 7 | services: 8 | postgres: 9 | image: postgres:14 10 | env: 11 | POSTGRES_USER: postgres 12 | POSTGRES_PASSWORD: postgres 13 | POSTGRES_DB: postgres 14 | ports: 15 | - 5432/tcp 16 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5 17 | 18 | steps: 19 | - name: Checkout 20 | uses: actions/checkout@master 21 | 22 | - name: Install Racket 23 | uses: Bogdanp/setup-racket@v1.9 24 | with: 25 | version: "8.7" 26 | 27 | - name: TEMP Install patched version of sasl-lib 28 | run: sudo raco pkg update --scope installation git://github.com/Bogdanp/sasl.git?path=sasl-lib 29 | 30 | - name: Install pkg and deps 31 | run: raco pkg install --batch --auto north/ 32 | 33 | - name: Run tests 34 | run: ./run-all-tests.sh 35 | working-directory: tests 36 | env: 37 | PG_DATABASE_URL: postgres://postgres:postgres@127.0.0.1:${{ job.services.postgres.ports[5432] }}/postgres 38 | DATABASE_URL: postgres://north_tests:north_tests@127.0.0.1:${{ job.services.postgres.ports[5432] }}/north_tests 39 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | coverage 3 | doc 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # racket-north [![CI](https://github.com/Bogdanp/racket-north/workflows/CI/badge.svg)](https://github.com/Bogdanp/racket-north/actions?query=workflow%3ACI) 2 | 3 | A database migration tool written in Racket. 4 | 5 | ## Documentation 6 | 7 | The documentation for this library is hosted on [docs.racket-lang.org](http://docs.racket-lang.org/north/index.html). 8 | 9 | ## License 10 | 11 | north is licensed under the 3-Clause BSD license. 12 | -------------------------------------------------------------------------------- /north/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /north/adapter/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/generic) 4 | 5 | (provide (all-defined-out)) 6 | 7 | (define-logger north-adapter) 8 | 9 | (define-generics adapter 10 | (adapter-init adapter) 11 | (adapter-current-revision adapter) 12 | (adapter-apply! adapter revision scripts)) 13 | 14 | (struct exn:fail:adapter exn:fail (cause)) 15 | (struct exn:fail:adapter:migration exn:fail:adapter (revision)) 16 | -------------------------------------------------------------------------------- /north/adapter/postgres.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require db 4 | net/url 5 | racket/contract/base 6 | racket/format 7 | racket/lazy-require 8 | racket/match 9 | "base.rkt") 10 | 11 | (provide 12 | (contract-out 13 | [struct postgres-adapter ([conn connection?])] 14 | [url->postgres-adapter (-> url? adapter?)])) 15 | 16 | (define CREATE-SCHEMA-TABLE #<postgres-adapter url) 53 | (define (oops message) 54 | (raise 55 | (exn:fail:adapter 56 | (~a message 57 | "\n connection URLs must have the form:" 58 | "\n postgres://[username[:password]@]hostname[:port]/database_name[?sslmode=prefer|require|disable]") 59 | (current-continuation-marks) 60 | #f))) 61 | (define host (url-host url)) 62 | (when (string=? host "") 63 | (oops "host missing")) 64 | (define path (url-path url)) 65 | (when (null? path) 66 | (oops "database_name missing")) 67 | (define database 68 | (path/param-path (car (url-path url)))) 69 | (match-define (list _ username password) 70 | (regexp-match #px"([^:]+)(?::(.+))?" (or (url-user url) "root"))) 71 | (define sslmode 72 | (match (assq 'sslmode (url-query url)) 73 | [#f 'no] 74 | ['(sslmode . "disable") 'no] 75 | ['(sslmode . "require") 'yes] 76 | ['(sslmode . "prefer") 'optional] 77 | [`(sslmode . #f) (oops "empty `sslmode'")] 78 | [`(sslmode . ,value) (oops (format "invalid `sslmode' value: ~e" value))])) 79 | 80 | (postgres-adapter 81 | (postgresql-connect #:database database 82 | #:server host 83 | #:port (url-port url) 84 | #:ssl sslmode 85 | #:user username 86 | #:password password))) 87 | -------------------------------------------------------------------------------- /north/adapter/sqlite.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require db 4 | net/url 5 | racket/contract/base 6 | racket/format 7 | "base.rkt") 8 | 9 | (provide 10 | (contract-out 11 | [struct sqlite-adapter ([conn connection?])] 12 | [url->sqlite-adapter (-> url? adapter?)])) 13 | 14 | (define CREATE-SCHEMA-TABLE #<sqlite-adapter url) 49 | (sqlite-adapter 50 | (sqlite3-connect 51 | #:database (make-db-path url) 52 | #:mode 'create))) 53 | 54 | (define (make-db-path url) 55 | (define parts 56 | (for*/list ([part (in-list (url-path url))] 57 | [path (in-value (path/param-path part))]) 58 | (cond 59 | [(symbol? path) path] 60 | [(string=? path "") "/"] 61 | [else path]))) 62 | (when (or (null? parts) 63 | (equal? parts '(""))) 64 | (error 'url->sqlite-adapter "sqlite3 connection URL must contain a path")) 65 | (when (and (url-host url) 66 | (not (string=? (url-host url) ""))) 67 | (error 'url->sqlite-adapter "sqlite3 connection URL must either start with 0 or 3 slashes")) 68 | (apply build-path parts)) 69 | 70 | (module+ test 71 | (require net/url rackunit) 72 | 73 | (define make 74 | (compose1 path->string make-db-path string->url)) 75 | 76 | (for ([(s e) (in-hash (hash "sqlite:db.sqlite3" "db.sqlite3" 77 | "sqlite:///db.sqlite3" "db.sqlite3" 78 | "sqlite:///a/db.sqlite3" "a/db.sqlite3" 79 | "sqlite:////a/db.sqlite3" "/a/db.sqlite3"))]) 80 | (check-equal? (make s) e)) 81 | 82 | (for ([s (in-list (list "sqlite://" 83 | "sqlite://a/" 84 | "sqlite://a/db.sqlite3"))]) 85 | (check-exn 86 | exn:fail? 87 | (lambda () 88 | (make s))))) 89 | -------------------------------------------------------------------------------- /north/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax 5 | syntax/parse/pre) 6 | racket/contract/base 7 | racket/file 8 | racket/match 9 | racket/path) 10 | 11 | (provide 12 | (struct-out exn:fail:migration) 13 | 14 | (contract-out 15 | [struct migration 16 | ([metadata hash?] 17 | [child (or/c #f migration?)])] 18 | [path->migration (-> path-string? (or/c #f migration?))] 19 | [migration->list (->* [migration?] [#:stop-at (or/c #f string?)] (listof migration?))] 20 | [migration-most-recent (-> migration? migration?)] 21 | [migration-find-parent (-> migration? string? (or/c #f migration?))] 22 | [migration-find-revision (-> migration? string? (or/c #f migration?))] 23 | [migration-plan (-> migration? (or/c #f string?) (or/c #f string?) (listof migration?))])) 24 | 25 | (define (migration-path? p) 26 | (and (not (directory-exists? p)) 27 | (equal? (path-get-extension p) #".sql"))) 28 | 29 | (define (read-all-metadata path) 30 | (for/list ([filename (in-list (find-files migration-path? path))]) 31 | (dynamic-require filename 'metadata))) 32 | 33 | (struct migration (metadata child) #:transparent) ;; noqa 34 | (struct exn:fail:migration exn:fail ()) 35 | 36 | (define-syntax (define-accessor stx) 37 | (syntax-parse stx 38 | [(_ id:id (~optional c-expr:expr)) 39 | #:with accessor-id (format-id #'id "migration-~a" (syntax-e #'id)) 40 | #'(begin 41 | (define (accessor-id migration) 42 | (hash-ref (migration-metadata migration) 'id #f)) 43 | (provide 44 | (contract-out 45 | [accessor-id (-> migration? (or/c #f (~? c-expr string?)))])))])) 46 | 47 | (define-syntax-rule (define-accessors id ...) 48 | (begin (define-accessor id) ...)) 49 | 50 | (define-accessors name revision parent path description) 51 | (define-accessor up (listof string?)) 52 | (define-accessor down (listof string?)) 53 | 54 | (define (path->migration path) 55 | (define metadata-by-parent 56 | (for/fold ([metadata-by-parent (hash)]) 57 | ([metadata (read-all-metadata path)]) 58 | (define parent (hash-ref metadata 'parent #f)) 59 | (define conflict? (hash-ref metadata-by-parent parent #f)) 60 | (when conflict? 61 | (raise (exn:fail:migration (format "parent ~a is shared by revisions ~a and ~a" 62 | parent 63 | (hash-ref metadata 'revision) 64 | (hash-ref conflict? 'revision)) 65 | (current-continuation-marks)))) 66 | (hash-set metadata-by-parent parent metadata))) 67 | 68 | (define (make-migration metadata) 69 | (define revision (hash-ref metadata 'revision)) 70 | (define child-metadata (hash-ref metadata-by-parent revision #f)) 71 | (define child (and child-metadata (make-migration child-metadata))) 72 | (migration metadata child)) 73 | 74 | ;; Base is added in to make operations such as rolling back all the way easier. 75 | (define root (hash-ref metadata-by-parent #f #f)) 76 | (and root (migration (hasheq 'revision "base" 'parent "base" 'up null 'down null) 77 | (make-migration (hash-set root 'parent "base"))))) 78 | 79 | (define (migration->list node #:stop-at [stop-at #f]) 80 | (reverse 81 | (let loop ([current node] 82 | [results null]) 83 | (define child (migration-child current)) 84 | (cond 85 | [(not child) 86 | (cons current results)] 87 | 88 | [(and stop-at (string=? stop-at (migration-revision current))) 89 | (cons current results)] 90 | 91 | [else 92 | (loop child (cons current results))])))) 93 | 94 | (define (migration-most-recent node) 95 | (let loop ([current node]) 96 | (define child (migration-child current)) 97 | (cond 98 | [child (loop child)] 99 | [else current]))) 100 | 101 | (define (migration-find-parent node revision) 102 | (define current-migration (migration-find-revision node revision)) 103 | (migration-find-revision node (migration-parent current-migration))) 104 | 105 | (define (migration-find-revision node revision) 106 | (cond 107 | [(not node) #f] 108 | [(string=? (migration-revision node) revision) node] 109 | [else (migration-find-revision (migration-child node) revision)])) 110 | 111 | (define (migration-parent-of? a b) 112 | (and (migration-find-revision a (migration-revision b)) #t)) 113 | 114 | (define (migration-plan node from-revision to-revision) 115 | (match (list from-revision to-revision) 116 | [(list #f #f) (migration->list node)] 117 | [(list #f r) (migration->list node #:stop-at r)] 118 | [(list r #f) (reverse (migration->list node #:stop-at r))] 119 | 120 | [(list r1 r2) 121 | (define m1 (migration-find-revision node r1)) 122 | (unless m1 123 | (raise-not-found 'migration-plan r1)) 124 | 125 | (define m2 (migration-find-revision node r2)) 126 | (unless m2 127 | (raise-not-found 'migration-plan r2)) 128 | 129 | (cond 130 | [(migration-parent-of? m1 m2) 131 | (cdr (migration->list m1 #:stop-at r2))] 132 | 133 | [(migration-parent-of? m2 m1) 134 | (reverse (cdr (migration->list m2 #:stop-at r1)))] 135 | 136 | [else 137 | (error 'migration-plan "could not determine relationship between revision ~a and revision ~a" r1 r2)])])) 138 | 139 | (define (raise-not-found who revision) 140 | (error who "could not find revision ~a among the migrations~n hint: you may be trying to migrate the wrong database" revision)) 141 | 142 | (module+ test 143 | (require rackunit) 144 | 145 | (define head 146 | (migration 147 | (hasheq 148 | 'revision "d" 149 | 'parent "c" 150 | 'name "20190128-alter-users-add-last-login.sql" 151 | 'up '("d up") 152 | 'down '("d down")) #f)) 153 | 154 | (define base 155 | (migration 156 | (hasheq 157 | 'revision "a" 158 | 'parent #f 159 | 'name "20190126-create-users-table.sql" 160 | 'up '("a up") 161 | 'down '("a down")) 162 | (migration 163 | (hasheq 164 | 'revision "b" 165 | 'parent "a" 166 | 'name "20190127-alter-users-add-created-at.sql" 167 | 'up '("b up") 168 | 'down '("b down")) 169 | (migration 170 | (hasheq 171 | 'revision "c" 172 | 'parent "b" 173 | 'name "20190127-alter-users-add-updated-at.sql" 174 | 'up '("c up") 175 | 'down '("c down")) head)))) 176 | 177 | (check-equal? 178 | (migration-most-recent base) 179 | (migration-find-revision base "d")) 180 | 181 | (check-false (migration-find-revision base "invalid")) 182 | (check-equal? (migration-find-revision base "a") base) 183 | (check-equal? (migration-find-revision base "d") head) 184 | 185 | (check-true (migration-parent-of? base (migration-find-revision base "d"))) 186 | (check-true (migration-parent-of? (migration-find-revision base "c") (migration-find-revision base "d"))) 187 | (check-true (migration-parent-of? (migration-find-revision base "b") (migration-find-revision base "d"))) 188 | (check-false (migration-parent-of? (migration-find-revision base "d") base)) 189 | 190 | (check-equal? 191 | (migration-plan base #f #f) 192 | (list (migration-find-revision base "a") 193 | (migration-find-revision base "b") 194 | (migration-find-revision base "c") 195 | (migration-find-revision base "d"))) 196 | 197 | (check-equal? 198 | (migration-plan base #f "b") 199 | (list (migration-find-revision base "a") 200 | (migration-find-revision base "b"))) 201 | 202 | (check-equal? 203 | (migration-plan base #f "c") 204 | (list (migration-find-revision base "a") 205 | (migration-find-revision base "b") 206 | (migration-find-revision base "c"))) 207 | 208 | (check-equal? 209 | (migration-plan base "c" #f) 210 | (list (migration-find-revision base "c") 211 | (migration-find-revision base "b") 212 | (migration-find-revision base "a"))) 213 | 214 | (check-equal? 215 | (migration-plan base "b" #f) 216 | (list (migration-find-revision base "b") 217 | (migration-find-revision base "a"))) 218 | 219 | (check-equal? 220 | (migration-plan base "a" "c") 221 | (list (migration-find-revision base "b") 222 | (migration-find-revision base "c"))) 223 | 224 | (check-equal? 225 | (migration-plan base "b" "d") 226 | (list (migration-find-revision base "c") 227 | (migration-find-revision base "d"))) 228 | 229 | (check-equal? 230 | (migration-plan base "d" "a") 231 | (list (migration-find-revision base "d") 232 | (migration-find-revision base "c") 233 | (migration-find-revision base "b"))) 234 | 235 | (check-equal? 236 | (migration-plan base "d" "b") 237 | (list (migration-find-revision base "d") 238 | (migration-find-revision base "c")))) 239 | -------------------------------------------------------------------------------- /north/cli.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require db 4 | gregor 5 | net/url 6 | openssl/md5 7 | racket/cmdline 8 | racket/format 9 | racket/function 10 | racket/match 11 | racket/port 12 | raco/command-name 13 | "adapter/base.rkt" 14 | "adapter/postgres.rkt" 15 | "adapter/sqlite.rkt" 16 | "base.rkt") 17 | 18 | (define current-program-name 19 | (make-parameter (short-program+command-name))) 20 | 21 | (define database-url 22 | (make-parameter (getenv "DATABASE_URL"))) 23 | 24 | (define dry-run? 25 | (make-parameter #t)) 26 | 27 | (define migrations-path 28 | (make-parameter 29 | (build-path (current-directory) "migrations") 30 | (lambda (p) 31 | (unless (directory-exists? p) 32 | (exit-with-errors! @~a{error: migrations path '@p' does not exist})) 33 | 34 | p))) 35 | 36 | (define adapter-factories 37 | (hasheq 'postgres url->postgres-adapter 38 | 'sqlite url->sqlite-adapter)) 39 | 40 | (define (make-adapter dsn) 41 | (define url (string->url dsn)) 42 | (define factory (hash-ref adapter-factories (string->symbol (url-scheme url)) #f)) 43 | (and factory (factory url))) 44 | 45 | (define root-revision-template #<string) 77 | (~t (today) "yyyyMMdd")) 78 | 79 | (define (generate-revision-id name) 80 | (call-with-input-string (~a (datetime->iso8601 (now)) name) md5)) 81 | 82 | (define (generate-revision-filename name) 83 | (build-path (migrations-path) (~a (current-date->string) "-" name ".sql"))) 84 | 85 | (define (exit-with-errors! . messages) 86 | (parameterize ([current-output-port (current-error-port)]) 87 | (for ([message messages]) 88 | (displayln message))) 89 | (exit 1)) 90 | 91 | (define (exit-with-adapter-error! e) 92 | (define revision (exn:fail:adapter:migration-revision e)) 93 | (define info (exn:fail:sql-info (exn:fail:adapter-cause e))) 94 | (apply exit-with-errors! 95 | @~a{error: failed to apply revision @revision} 96 | @~a{details:} 97 | (for/list ([i info]) 98 | @~a{ @(car i): @(cdr i)}))) 99 | 100 | (define (read-migrations) 101 | (with-handlers ([exn:fail:migration? 102 | (lambda (e) 103 | (exit-with-errors! @~a{error: @(exn-message e)}))] 104 | 105 | [exn:fail:read? 106 | (lambda (e) 107 | (exit-with-errors! @~a{error: @(exn-message e)}))] 108 | 109 | [exn:fail? 110 | (lambda (_) 111 | (exit-with-errors! @~a{error: '@(migrations-path)' folder not found}))]) 112 | (path->migration (migrations-path)))) 113 | 114 | (define (parse-migrator-args _command) 115 | (define revision 116 | (command-line 117 | #:program (current-program-name) 118 | #:once-each 119 | [("-f" "--force") "Unless specified, none of the operations will be applied." 120 | (dry-run? #f)] 121 | 122 | [("-u" "--database-url") url 123 | "The URL with which to connect to the database." 124 | (database-url url)] 125 | 126 | [("-p" "--path") path 127 | "The path to the migrations folder." 128 | (migrations-path path)] 129 | 130 | #:args ([revision #f]) revision)) 131 | 132 | (unless (database-url) 133 | (exit-with-errors! "error: no database url")) 134 | 135 | (define base (read-migrations)) 136 | (unless base 137 | (exit-with-errors! "error: no migrations")) 138 | 139 | (define adapter (make-adapter (database-url))) 140 | (unless adapter 141 | (exit-with-errors! "error: no adapter")) 142 | 143 | (adapter-init adapter) 144 | (values adapter base (adapter-current-revision adapter) revision)) 145 | 146 | (define (print-message message) 147 | (if (and (dry-run?) (not (string=? message ""))) 148 | (displayln (~a "-- " message)) 149 | (displayln message))) 150 | 151 | (define (print-dry-run migration script-proc) 152 | (unless (string=? (migration-revision migration) "base") 153 | (define scripts (script-proc migration)) 154 | (print-message @~a{Revision: @(migration-revision migration)}) 155 | (print-message @~a{Parent: @(migration-parent migration)}) 156 | (print-message @~a{Path: @(migration-path migration)}) 157 | (cond 158 | [(null? scripts) (displayln "-- no content --")] 159 | [else (for-each displayln scripts)]))) 160 | 161 | (define (print-migration migration) 162 | (unless (string=? (migration-revision migration) "base") 163 | (print-message @~a{Revision: @(migration-revision migration)}) 164 | (print-message @~a{Parent: @(migration-parent migration)}) 165 | (print-message @~a{Path: @(migration-path migration)}) 166 | (print-message @~a{Description: @(migration-description migration)}) 167 | (print-message ""))) 168 | 169 | (define (handle-help) 170 | (exit-with-errors! 171 | "usage: raco north