source: project/release/4/nomads/trunk/nomads.scm @ 21993

Last change on this file since 21993 was 21993, checked in by certainty, 9 years ago

nomads: irreversible migrations can take an optional message now

File size: 14.1 KB
Line 
1;;
2;; Author: David Krentzlin
3;;
4;; Created: Do Nov 11 14:10:17 2010 (CET)
5;; Last-Updated: Di Dez 14 20:37:12 2010 (CET)
6;;           By:
7
8
9(module nomads
10(debug database-credentials migration-directory
11       filename-pattern filename-partitioner filename-joiner versioner 
12       version? version-less? version-equal? version< migrate
13       db-with-connection db-with-transaction db-schema-information-exists?
14       db-schema-version-table  db-initialize-schema-information db-version-list
15       migration-version migration-filename migration? error-on-non-existent-version
16       db-add-version db-remove-version db-execute-sql generate-migration db-latest-version version->string
17       string->version error-on-duplicate-migrations)
18
19(import chicken scheme)
20(require-library posix filepath defstruct data-structures srfi-1 srfi-13 extras)
21
22(import
23  defstruct
24  (only posix glob directory?)
25  (only extras sprintf printf)
26  (only data-structures sort compose string-split)
27  (only srfi-1 filter fold any)
28  (only srfi-13 string-downcase string-join)
29  (only filepath filepath:drop-extension filepath:combine filepath:split-file-name))
30
31(define debug (make-parameter #f))
32
33(define (dbg fmt . args)
34  (when (debug)
35    (display "*dbg*: ")
36    (apply printf fmt args)
37    (newline)
38    (flush-output)))
39
40
41(define error-on-duplicate-migrations  (make-parameter #t))
42(define  error-on-non-existent-version (make-parameter #t))
43
44(define database-credentials          (make-parameter #f))
45(define migration-directory           (make-parameter #f))
46
47;; the following procedures help to abstract away the formatting of
48;; migratons-file-names as well as the versioning scheme
49(define filename-pattern              (make-parameter "*-*"))
50(define filename-partitioner      (make-parameter
51                                   (lambda (filename)
52                                     (let ((parts (string-split filename "-")))
53                                       (cond
54                                        ((< (length parts) 2) (cons #f filename))
55                                        (((string->version) (car parts))
56                                         => (lambda (num) (cons num (string-join (cdr parts) "-"))))
57                                        (else (cons #f filename)))))))
58
59(define filename-joiner           (make-parameter
60                                   (lambda (version file)
61                                     (sprintf "~A-~A" version file))))
62
63
64;; Parameterize this to implement you own versioning scheme
65(define versioner       (make-parameter
66                         (lambda (max-version)
67                           (if max-version
68                               (+ max-version 1)
69                               1))))
70
71
72
73(define version?        (make-parameter number?))
74(define version-less?   (make-parameter <))
75(define version-equal?  (make-parameter =))
76
77(define version->string (make-parameter
78                         (lambda (str)
79                           (cond
80                            ((string? str) str)
81                            ((number? str) (number->string str))
82                            (else #f)))))
83
84(define string->version (make-parameter
85                         (lambda ( version)
86                           (cond
87                            ((number? version) version)
88                            ((string? version) (string->number version))
89                            (else #f)))))
90
91
92(define (version< lhs rhs)
93  ((version-less?) lhs rhs))
94
95(define (version> lhs rhs)
96  (version< rhs lhs))
97
98(define (version= lhs rhs)
99  ((version-equal?) lhs rhs))
100
101(define (version<= lhs rhs)
102  (or (version< lhs rhs) (version= lhs rhs)))
103
104(define (version-max version . other-versions)
105  (fold (lambda (x xs)
106          (if (version> x xs) x xs))
107        version
108        other-versions))
109
110
111
112;;representation of a migration
113(defstruct migration version filename statements)
114
115;; If you want to provide a database-api you have to
116;; bind these parameters
117
118(define db-schema-version-table       (make-parameter "schema_info"))
119
120;;(lambda (db-credentials proc) ...)
121(define db-with-connection                (make-parameter #f))
122
123;;(lambda (db thunk) ...)
124(define db-with-transaction               (make-parameter #f))
125
126;;(lambda (db) ...)
127(define db-schema-information-exists?     (make-parameter #f))
128
129;;(lambda (db) ...)
130(define db-initialize-schema-information  (make-parameter #f))
131
132;;(lambda (db) ...)
133(define db-version-list                 (make-parameter #f))
134
135;;(lambda (db version) ...)
136(define db-add-version                    (make-parameter #f))
137
138;;(lambda (db version) ...)
139(define db-remove-version                 (make-parameter #f))
140
141;;(lambda (db sql) ...)
142(define db-execute-sql                    (make-parameter #f))
143
144
145(define (db-latest-version db)
146  (let loop ((ls (map (string->version) ((db-version-list) db (db-schema-version-table)))) (latest #f))
147    (unless (null? ls)
148      (dbg "Checking: ~S" (car ls)))
149    (cond
150     ((null? ls)                 latest)
151     ((not latest)               (loop (cdr ls) (car ls)))
152     ((version< latest (car ls)) (loop (cdr ls) (car ls)) )
153     (else                       (loop (cdr ls) latest)))))
154
155
156
157(define migration-template "((UP\n  \"Fill in upward statements\")\n(DOWN\n  \"Fill in downward statements\"))")
158
159
160;;generate a migration stub and return its name
161(define (generate-migration name)
162  (unless (migration-directory)
163    (error "Migration directory has not been set"))
164 
165  (let* ((filename (generate-migration-file-name name))
166         (full-path (filepath:combine (migration-directory) filename)))
167    (call-with-output-file full-path (cut display migration-template <>))
168    filename))
169
170(define (generate-migration-file-name name)
171  (let ((latest (latest-file-version)))
172    ((filename-joiner) ((versioner) latest) name)))
173
174(define (latest-file-version)
175  (let ((migs (reverse (load-migrations))))
176    (if (null? migs) #f (migration-version (car migs)))))
177
178
179(define (make-nomads-condition  message arguments)
180  (apply make-property-condition
181         'nomads-error
182         (append
183          (if message (list 'message message) '())
184          (if (and arguments (not (null? arguments))) (list 'arguments arguments) '()))) )
185
186(define (complain kind fmt . args)
187  (signal
188   (make-composite-condition
189    (make-nomads-condition fmt args)
190    (make-property-condition kind))))
191
192(define (default-callback checkpoint irreversible?)
193  (let ((direction (car checkpoint))
194        (migration (cdr checkpoint)))
195    (printf "[~A][~A]: ~A [~A]~%"
196      (migration-version migration)
197      direction
198      (filepath:drop-extension
199       (migration-filename migration))
200      (if irreversible? "IRREVERSIBLE" "OK"))))
201
202;; This is the basic migration procedure
203;; version :: can be a specific version or either of (latest
204;;            earliest)
205;; callback :: a procedure that is called after the invocation of
206;; each checkpoint. It is passed the check-point and a boolean that
207;; indicates if the checkpoint was irreversible
208(define (migrate #!key (version 'latest) (callback default-callback))
209  (assert-proper-version version)
210  (assert-proper-configuration)
211  ((db-with-connection) (database-credentials)
212   (cut load-and-run-migrations <> callback version)))
213
214(define (assert-proper-configuration)
215  (unless (migration-directory)
216    (error "Migration directory has not been set"))
217
218  (unless (directory? (migration-directory))
219    (error "The migration directory does not seem to be a directory. " (migration-directory)))
220 
221  (unless (database-credentials)
222    (error "You must set the database credentials")))
223
224(define (assert-proper-version version)
225  (unless (or (eq? version 'latest)
226              (eq? version 'earliest)
227              ((version?) version))
228    (error "You need to supply a valid version")))
229
230(define (load-and-run-migrations db callback #!optional (target-version 'latest))   
231  (unless ((db-schema-information-exists?) db (db-schema-version-table))
232    ((db-initialize-schema-information) db (db-schema-version-table)))
233 
234  (let ((migration-path (build-migration-path db target-version)))
235    (call-with-current-continuation
236     (lambda (exit)
237       (for-each
238        (lambda (check-point)
239          (run-check-point db check-point exit callback)) migration-path)))))
240
241;; this procedure builds up the migration path to walk.
242;; It returns a list of check-points to visit.
243;; The loading of the actual migration code is limited to those
244;; migrations that are actually needed. This is a feature.
245(define (build-migration-path db target-version)
246  (let ((migrations (load-migrations)))
247    (dbg "migrations: ~A" migrations)
248
249    ;;perform checks on the target version
250    (if (and (error-on-non-existent-version)
251             (not (or (eq? target-version 'earliest)
252                      (eq? target-version 'latest)
253                      (any (lambda (mig) (version= (migration-version mig) target-version)) migrations))))
254      (complain 'non-existent-version "The requested target version does not exist" target-version))
255    (if (null? migrations) (list)
256        (let ((max-file-version (apply version-max (map migration-version migrations)))
257              (db-version (db-latest-version db)))
258          (dbg "Max: ~A DB: ~A" max-file-version db-version)
259          (cond
260           ((and (not db-version) (eq? target-version 'latest))
261            (map (cut build-check-point 'up <>) migrations))
262           ((and (not db-version) (eq? target-version 'earliest))
263            (list))
264           ((not db-version)
265            (map (cut build-check-point 'up <>)   (select-range migrations to: target-version)))
266           ((eq? target-version 'latest)
267            (map (cut build-check-point 'up <>)   (select-range migrations from: db-version to: max-file-version)))
268           ((eq? target-version 'earliest)
269            (map (cut build-check-point 'down <>) (reverse (select-range migrations to: db-version))))
270           ((version> target-version db-version)
271            (map (cut build-check-point 'up <>)   (select-range migrations from: db-version to: target-version)))
272           ((version< target-version db-version)
273            (map (cut build-check-point 'down <>) (reverse (select-range migrations from: target-version to: db-version))))
274           (else (list)))))))
275
276;; a check-point is a complete migration (with statemts read) plus
277;; its direction
278(define (build-check-point direction migration)
279  (migration-statements-set! migration (load-migration-file migration))
280  (cons direction migration))
281
282;; load the content of the migration
283(define (load-migration-file mig)
284  (let ((path (filepath:combine
285               (migration-directory)
286               ((filename-joiner) (migration-version mig) (migration-filename mig)))))
287    (if (file-exists? path)
288        (handle-exceptions
289            exn
290            (complain 'invalid-migration "Invalid migration file: " path)
291          (let ((form (eval (list 'quasiquote (call-with-input-file path read)))))
292            (unless (list? form)
293              (complain 'invalid-migration "Invalid migration file: " path))
294            form)))))
295
296(define (select-range migs #!key (from #f) (to #f))
297  (cond
298   ((and (not from) (not to)) migs)
299   ((not from)
300    (filter
301     (lambda (mig)
302       (version<= (migration-version mig) to)) migs))
303   (else
304    (filter
305     (lambda (mig)
306       (and (version>  (migration-version mig) from)
307            (version<= (migration-version mig) to))) migs))))
308
309;; create the migration objects from the migration-files in the
310;; migration-directory.
311;; NOTE: this procedure returns only partial migrations. In
312;; particular, the migrations have no valid statements-attribute yet
313(define (load-migrations)
314  (let ((pattern (filepath:combine (migration-directory) (filename-pattern))))
315    (sort
316     (filter migration? (map build-migration (glob pattern)))
317     (lambda (lhs rhs)
318       (when (and (error-on-duplicate-migrations)
319                  (version= (migration-version lhs) (migration-version rhs)))
320         (complain 'duplicate-version "You have two migrations with equal versions: " (migration-filename lhs) (migration-filename rhs)))
321       (version< (migration-version lhs)
322                 (migration-version rhs))))))
323
324(define (build-migration path)
325  (let* ((parts (filepath:split-file-name path))
326         (particels ((filename-partitioner) (cadr parts))))
327    (dbg "Extracted particels ~A" particels)
328    (if (car particels)
329        (make-migration version: (car particels) filename: (cdr particels))
330        #f)))
331
332;; This is the piece of code that does actually execute a step of
333;; the migration.
334;; Each check-point is executed in a transaction.
335(define (run-check-point db check-point exit callback)
336  (dbg "Running check-point")
337  (let* ((direction (car check-point))
338         (migration (cdr check-point))
339         (stmts     (statements-for-direction db (migration-statements migration) direction)))
340    ((db-with-transaction) db
341     (lambda ()
342       (run-statements db stmts (lambda (#!optional (message ""))
343                                  (callback check-point #t message)
344                                  (exit #f)))
345       (finish-check-point db migration direction)))
346    (callback check-point #f)))
347
348(define (statements-for-direction db statements direction)
349  (let loop ((ls statements))
350    (cond
351     ((null? ls) (list ""))
352     ((symbol-equal-ci? (caar ls) direction)
353      (cdar ls))
354     (else (loop (cdr ls))))))
355
356(define (symbol-equal-ci? lsym rsym)
357  (let ((str/down (compose string-downcase symbol->string)))
358    (equal? (str/down lsym) (str/down rsym))))
359
360(define (run-statements db statements irreversible)
361  (for-each
362   (lambda (stmt)
363     (cond
364      ((eq? stmt #f)     (irreversible))
365      ((and (pair? stmt) (eq? (car stmt) #f) (string? (cdr stmt)))
366       (irreversible (cdr stmt)))
367      ((procedure? stmt) (stmt db))
368      ((string? stmt)    ((db-execute-sql) db stmt))
369      (else              (error "Invalid Statement given"))))
370   statements))
371
372(define (finish-check-point db migration direction)
373  (case direction
374    ((down) ((db-remove-version) db ((version->string) (migration-version migration)) (db-schema-version-table)))
375    ((up)   ((db-add-version)    db ((version->string) (migration-version migration)) (db-schema-version-table)))
376    (else                        (error "Invalid direction"))))
377)
378;; module
Note: See TracBrowser for help on using the repository browser.