Skip to content

Commit 5090bd6

Browse files
fukamachifukamachi
committed
Fix the migration code for changing columns for the primary key.
1 parent 437453c commit 5090bd6

File tree

3 files changed

+165
-71
lines changed

3 files changed

+165
-71
lines changed

‎src/migration/table.lisp

+40-23
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,8 @@
4141
(:import-from #:alexandria
4242
#:ensure-list
4343
#:compose
44-
#:delete-from-plist)
44+
#:delete-from-plist
45+
#:remove-from-plist)
4546
(:export #:*auto-migration-mode*
4647
#:*migration-keep-temp-tables*
4748
#:migrate-table
@@ -64,17 +65,18 @@ If this variable is T they won't be deleted after migration.")
6465
(mapc #'execute-sql
6566
(migration-expressions class))))))
6667

67-
(defun plist= (plist1 plist2)
68-
(equalp (sort
69-
(loop for (k v) on plist1 by #'cddr
70-
collect (cons k v))
71-
#'string<
72-
:key #'car)
73-
(sort
74-
(loop for (k v) on plist2 by #'cddr
75-
collect (cons k v))
76-
#'string<
77-
:key #'car)))
68+
(defun plist= (plist1 plist2 &key (test 'equalp))
69+
(every test
70+
(sort
71+
(loop for (k v) on plist1 by #'cddr
72+
collect (cons k v))
73+
#'string<
74+
:key #'car)
75+
(sort
76+
(loop for (k v) on plist2 by #'cddr
77+
collect (cons k v))
78+
#'string<
79+
:key #'car)))
7880

7981
(defun column-definition-equal-p (column1 column2)
8082
(and (equal (first column1) (first column2))
@@ -225,7 +227,10 @@ If this variable is T they won't be deleted after migration.")
225227
with after-alter-sequences = '()
226228
for db-column in columns-intersection
227229
for table-column = (find (car db-column) to-columns :test #'string= :key #'car)
228-
unless (column-definition-equal-p db-column table-column)
230+
unless (column-definition-equal-p (cons (car db-column)
231+
(remove-from-plist (cdr db-column) :primary-key))
232+
(cons (car table-column)
233+
(remove-from-plist (cdr table-column) :primary-key)))
229234
append (case driver-type
230235
(:postgres
231236
(loop for (k v) on (cdr table-column) by #'cddr
@@ -307,16 +312,28 @@ If this variable is T they won't be deleted after migration.")
307312
:test #'string=))
308313
(getf options :columns))
309314
append
310-
(nconc
311-
(when (and (not (eq driver-type :postgres))
312-
(getf options :primary-key))
313-
(list (sxql:make-statement :alter-table (sxql:make-sql-symbol table-name)
314-
(sxql:drop-primary-key))))
315-
(list
316-
(apply #'sxql:drop-index index-name
317-
(if (eq driver-type :postgres)
318-
nil
319-
(list :on (sxql:make-sql-symbol table-name))))))))))))
315+
(if (eq driver-type :postgres)
316+
(if (getf options :primary-key)
317+
(list
318+
(sxql:make-statement :alter-table (sxql:make-sql-symbol table-name)
319+
(sxql:drop-constraint (sxql:make-sql-symbol index-name))))
320+
(list
321+
(sxql:drop-index index-name)))
322+
(nconc
323+
(when (getf options :primary-key)
324+
(let ((column (and (null (cdr (getf options :columns)))
325+
(find (car (getf options :columns)) from-columns
326+
:test 'equal
327+
:key #'first))))
328+
(list (sxql:make-statement :alter-table (sxql:make-sql-symbol table-name)
329+
(if (and column
330+
(getf (cdr column) :auto-increment))
331+
(apply #'sxql:make-clause :modify-column (sxql:make-sql-symbol (car column))
332+
(remove-from-plist (cdr column) :auto-increment :primary-key))
333+
(sxql:drop-primary-key))))))
334+
(list
335+
(sxql:drop-index index-name
336+
:on (sxql:make-sql-symbol table-name)))))))))))
320337

321338
(defun omit-default (definitions)
322339
(mapcar (lambda (definition)

‎t/migration/mysql.lisp

+73-33
Original file line numberDiff line numberDiff line change
@@ -98,14 +98,15 @@
9898
'(nil nil nil nil nil))
9999
"No migration after migrating"))
100100

101-
(testing "redefinition"
101+
(testing "redefinition of primary key"
102102
(defclass tweets ()
103-
((tweet-id :col-type :serial
103+
((tweet-id :col-type :bigserial
104104
:primary-key t
105105
:reader tweet-id)
106-
(user :col-type (:varchar 64)
107-
:accessor tweet-user)
108-
(created-at :col-type (:char 8)))
106+
(status :col-type :text
107+
:accessor tweet-status)
108+
(user :col-type (:varchar 128)
109+
:accessor tweet-user))
109110
(:metaclass dao-table-class)
110111
(:record-timestamps nil))
111112

@@ -115,12 +116,11 @@
115116
add-indices
116117
drop-indices)
117118
(mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql)
118-
(ok (equal (mapcar #'sxql:yield add-columns)
119-
'("ALTER TABLE tweets ADD COLUMN created_at char(8) NOT NULL")))
120-
(ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN status")))
119+
(ok (null add-columns))
120+
(ok (null drop-columns))
121121
(ok (equal (format nil "~{~A~^~%~}"
122122
(mapcar #'sxql:yield change-columns))
123-
"ALTER TABLE tweets MODIFY COLUMN user varchar(64) NOT NULL"))
123+
"ALTER TABLE tweets MODIFY COLUMN tweet_id bigint unsigned NOT NULL AUTO_INCREMENT"))
124124
(ok (null add-indices))
125125
(ok (null drop-indices)))
126126

@@ -130,28 +130,69 @@
130130
'(nil nil nil nil nil))
131131
"No migration after migrating"))
132132

133-
(testing "redefinition (modifying the column type)"
133+
(testing "Change to the serial primary key again"
134134
(defclass tweets ()
135-
((tweet-id :col-type :serial
136-
:primary-key t
135+
((tweet-id :col-type :bigint
137136
:reader tweet-id)
137+
(status :col-type :text
138+
:accessor tweet-status)
138139
(user :col-type (:varchar 128)
140+
:accessor tweet-user))
141+
(:metaclass dao-table-class)
142+
(:record-timestamps nil)
143+
(:unique-keys (tweet-id)))
144+
145+
(destructuring-bind (add-columns
146+
drop-columns
147+
change-columns
148+
add-indices
149+
drop-indices)
150+
(mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql)
151+
(ok (equal (mapcar #'sxql:yield add-columns)
152+
'("ALTER TABLE tweets ADD COLUMN id bigint unsigned NOT NULL AUTO_INCREMENT PRIMARY KEY"))
153+
"Add id")
154+
(ok (null drop-columns)
155+
"No columns to drop")
156+
(ok (equal (mapcar #'sxql:yield change-columns)
157+
'("ALTER TABLE tweets MODIFY COLUMN tweet_id bigint NOT NULL"))
158+
"Change the type of tweet_id")
159+
(ok (equal (mapcar #'sxql:yield add-indices)
160+
'("CREATE UNIQUE INDEX unique_tweets_tweet_id ON tweets (tweet_id)"))
161+
"Add a unique index")
162+
(ok (equal (mapcar #'sxql:yield drop-indices)
163+
'("ALTER TABLE tweets MODIFY COLUMN tweet_id bigint unsigned NOT NULL"
164+
"DROP INDEX PRIMARY ON tweets"))
165+
"Drop the primary key"))
166+
167+
(migrate-table (find-class 'tweets))
168+
169+
(ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql)
170+
'(nil nil nil nil nil))
171+
"No migration after migrating"))
172+
173+
(testing "redefinition"
174+
(defclass tweets ()
175+
((tweet-id :col-type :bigint
176+
:reader tweet-id)
177+
(user :col-type (:varchar 64)
139178
:accessor tweet-user)
140179
(created-at :col-type (:char 8)))
141180
(:metaclass dao-table-class)
142-
(:record-timestamps nil))
181+
(:record-timestamps nil)
182+
(:unique-keys (tweet-id)))
143183

144184
(destructuring-bind (add-columns
145185
drop-columns
146186
change-columns
147187
add-indices
148188
drop-indices)
149189
(mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql)
150-
(ok (null add-columns))
151-
(ok (null drop-columns))
190+
(ok (equal (mapcar #'sxql:yield add-columns)
191+
'("ALTER TABLE tweets ADD COLUMN created_at char(8) NOT NULL")))
192+
(ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN status")))
152193
(ok (equal (format nil "~{~A~^~%~}"
153194
(mapcar #'sxql:yield change-columns))
154-
"ALTER TABLE tweets MODIFY COLUMN user varchar(128) NOT NULL"))
195+
"ALTER TABLE tweets MODIFY COLUMN user varchar(64) NOT NULL"))
155196
(ok (null add-indices))
156197
(ok (null drop-indices)))
157198

@@ -161,16 +202,16 @@
161202
'(nil nil nil nil nil))
162203
"No migration after migrating"))
163204

164-
(testing "redefinition of primary key"
205+
(testing "redefinition (modifying the column type)"
165206
(defclass tweets ()
166-
((tweet-id :col-type :bigserial
167-
:primary-key t
207+
((tweet-id :col-type :bigint
168208
:reader tweet-id)
169209
(user :col-type (:varchar 128)
170210
:accessor tweet-user)
171211
(created-at :col-type (:char 8)))
172212
(:metaclass dao-table-class)
173-
(:record-timestamps nil))
213+
(:record-timestamps nil)
214+
(:unique-keys (tweet-id)))
174215

175216
(destructuring-bind (add-columns
176217
drop-columns
@@ -182,7 +223,7 @@
182223
(ok (null drop-columns))
183224
(ok (equal (format nil "~{~A~^~%~}"
184225
(mapcar #'sxql:yield change-columns))
185-
"ALTER TABLE tweets MODIFY COLUMN tweet_id bigint unsigned NOT NULL AUTO_INCREMENT"))
226+
"ALTER TABLE tweets MODIFY COLUMN user varchar(128) NOT NULL"))
186227
(ok (null add-indices))
187228
(ok (null drop-indices)))
188229

@@ -194,15 +235,14 @@
194235

195236
(testing "add :unique-keys"
196237
(defclass tweets ()
197-
((tweet-id :col-type :bigserial
198-
:primary-key t
238+
((tweet-id :col-type :bigint
199239
:reader tweet-id)
200240
(user :col-type (:varchar 128)
201241
:accessor tweet-user)
202242
(created-at :col-type (:char 8)))
203243
(:metaclass dao-table-class)
204-
(:unique-keys (user created-at))
205-
(:record-timestamps nil))
244+
(:record-timestamps nil)
245+
(:unique-keys (tweet-id) (user created-at)))
206246

207247
(destructuring-bind (add-columns
208248
drop-columns
@@ -226,15 +266,15 @@
226266

227267
(testing "modify :unique-keys"
228268
(defclass tweets ()
229-
((tweet-id :col-type :bigserial
230-
:primary-key t
269+
((tweet-id :col-type :bigint
231270
:reader tweet-id)
232271
(user :col-type (:varchar 128)
233272
:accessor tweet-user)
234273
(created-at :col-type (:char 8)))
235274
(:metaclass dao-table-class)
236-
(:unique-keys (tweet-id user created-at))
237-
(:record-timestamps nil))
275+
(:record-timestamps nil)
276+
(:unique-keys (tweet-id)
277+
(tweet-id user created-at)))
238278

239279
(destructuring-bind (add-columns
240280
drop-columns
@@ -259,15 +299,15 @@
259299

260300
(testing "delete :unique-keys and add :keys"
261301
(defclass tweets ()
262-
((tweet-id :col-type :bigserial
263-
:primary-key t
302+
((tweet-id :col-type :bigint
264303
:reader tweet-id)
265304
(user :col-type (:varchar 128)
266305
:accessor tweet-user)
267306
(created-at :col-type (:char 8)))
268307
(:metaclass dao-table-class)
269-
(:keys (user created-at))
270-
(:record-timestamps nil))
308+
(:record-timestamps nil)
309+
(:unique-keys (tweet-id))
310+
(:keys (user created-at)))
271311

272312
(destructuring-bind (add-columns
273313
drop-columns

0 commit comments

Comments
 (0)