refactoring by skill
This commit is contained in:
+99
-131
@@ -112,6 +112,12 @@ CREATE TABLE IF NOT EXISTS wiki_schema (
|
||||
SQL
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the newest recorded wiki database schema version.
|
||||
; pre : db is an open PostgreSQL connection.
|
||||
; post : Schema tables have only been inspected.
|
||||
; result : The highest recorded version, or 0 when wiki_schema does not exist.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (database-schema-version db)
|
||||
(if (table-exists? db "wiki_schema")
|
||||
(query-value db "SELECT COALESCE(MAX(version), 0) FROM wiki_schema")
|
||||
@@ -147,51 +153,51 @@ SQL
|
||||
(install-schema-1! db))))
|
||||
|
||||
(define (legacy-mime-type stored-name)
|
||||
(define lower (string-downcase stored-name))
|
||||
(cond
|
||||
((regexp-match? #px"[.]png$" lower) "image/png")
|
||||
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
|
||||
((regexp-match? #px"[.]gif$" lower) "image/gif")
|
||||
((regexp-match? #px"[.]webp$" lower) "image/webp")
|
||||
((regexp-match? #px"[.]pdf$" lower) "application/pdf")
|
||||
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
|
||||
(else "application/octet-stream")))
|
||||
(let ((lower (string-downcase stored-name)))
|
||||
(cond
|
||||
((regexp-match? #px"[.]png$" lower) "image/png")
|
||||
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
|
||||
((regexp-match? #px"[.]gif$" lower) "image/gif")
|
||||
((regexp-match? #px"[.]webp$" lower) "image/webp")
|
||||
((regexp-match? #px"[.]pdf$" lower) "application/pdf")
|
||||
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
|
||||
(else "application/octet-stream"))))
|
||||
|
||||
(define (migrate-1->2! db config)
|
||||
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS mime_type TEXT")
|
||||
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS content BYTEA")
|
||||
(define rows
|
||||
(query-rows db
|
||||
#<<SQL
|
||||
(let ((rows
|
||||
(query-rows db
|
||||
#<<SQL
|
||||
SELECT a.id, p.slug, a.stored_name, a.content
|
||||
FROM attachments a
|
||||
JOIN pages p ON p.id = a.page_id
|
||||
ORDER BY a.id
|
||||
SQL
|
||||
))
|
||||
(for ((row (in-list rows)))
|
||||
(define attachment-id (vector-ref row 0))
|
||||
(define slug (vector-ref row 1))
|
||||
(define stored-name (vector-ref row 2))
|
||||
(define content (vector-ref row 3))
|
||||
(unless (bytes? content)
|
||||
(define path (build-path (uploads-directory config) slug stored-name))
|
||||
(unless (file-exists? path)
|
||||
(error 'migrate-database!
|
||||
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
|
||||
stored-name
|
||||
(path->string path)))
|
||||
(define bytes (file->bytes path))
|
||||
(query-exec db
|
||||
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
|
||||
bytes
|
||||
(legacy-mime-type stored-name)
|
||||
(bytes-length bytes)
|
||||
attachment-id)))
|
||||
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN mime_type SET NOT NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
|
||||
(record-schema-version! db 2))
|
||||
)))
|
||||
(for ((row (in-list rows)))
|
||||
(let ((attachment-id (vector-ref row 0))
|
||||
(slug (vector-ref row 1))
|
||||
(stored-name (vector-ref row 2))
|
||||
(content (vector-ref row 3)))
|
||||
(unless (bytes? content)
|
||||
(let ((path (build-path (uploads-directory config) slug stored-name)))
|
||||
(unless (file-exists? path)
|
||||
(error 'migrate-database!
|
||||
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
|
||||
stored-name
|
||||
(path->string path)))
|
||||
(let ((bytes (file->bytes path)))
|
||||
(query-exec db
|
||||
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
|
||||
bytes
|
||||
(legacy-mime-type stored-name)
|
||||
(bytes-length bytes)
|
||||
attachment-id))))))
|
||||
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN mime_type SET NOT NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
|
||||
(record-schema-version! db 2)))
|
||||
|
||||
|
||||
(define (replace-page-todos! db page-id markdown)
|
||||
@@ -1092,10 +1098,10 @@ CREATE TEMP TABLE concept_uuid_rekey (
|
||||
) ON COMMIT DROP
|
||||
SQL
|
||||
)
|
||||
(define old-ids
|
||||
(query-list
|
||||
db
|
||||
#<<SQL
|
||||
(let* ((old-ids
|
||||
(query-list
|
||||
db
|
||||
#<<SQL
|
||||
WITH all_current_ids AS (
|
||||
SELECT id AS old_id FROM concept_definitions
|
||||
UNION
|
||||
@@ -1119,27 +1125,28 @@ FROM all_current_ids
|
||||
WHERE nullif(old_id, '') IS NOT NULL
|
||||
ORDER BY old_id
|
||||
SQL
|
||||
))
|
||||
;; Reserve every already canonical UUID before generating replacements, so a
|
||||
;; random id can never collide with a UUID encountered later in the query.
|
||||
(define used-ids (make-hash))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(define normalized (normalize-concept-id old-id))
|
||||
(when normalized (hash-set! used-ids normalized #t)))
|
||||
(define (fresh-unused-id)
|
||||
(let loop ()
|
||||
(define candidate (new-concept-id))
|
||||
(if (hash-has-key? used-ids candidate)
|
||||
(loop)
|
||||
(begin
|
||||
(hash-set! used-ids candidate #t)
|
||||
candidate))))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
|
||||
old-id
|
||||
(or (normalize-concept-id old-id) (fresh-unused-id))))
|
||||
))
|
||||
;; Reserve every already canonical UUID before generating replacements,
|
||||
;; so a random id can never collide with a UUID encountered later.
|
||||
(used-ids (make-hash)))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(let ((normalized (normalize-concept-id old-id)))
|
||||
(when normalized (hash-set! used-ids normalized #t))))
|
||||
(letrec ((fresh-unused-id
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(let ((candidate (new-concept-id)))
|
||||
(if (hash-has-key? used-ids candidate)
|
||||
(loop)
|
||||
(begin
|
||||
(hash-set! used-ids candidate #t)
|
||||
candidate)))))))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
|
||||
old-id
|
||||
(or (normalize-concept-id old-id) (fresh-unused-id)))))
|
||||
(query-exec
|
||||
db
|
||||
#<<SQL
|
||||
@@ -1205,7 +1212,7 @@ ADD CONSTRAINT concept_definitions_uuid_id_check
|
||||
CHECK (id ~ '^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$')
|
||||
SQL
|
||||
)
|
||||
(record-schema-version! db 21))
|
||||
(record-schema-version! db 21)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Bring a racket-wiki PostgreSQL database to the current schema.
|
||||
@@ -1219,72 +1226,33 @@ SQL
|
||||
db
|
||||
(λ ()
|
||||
(recognize-or-install-schema-1! db)
|
||||
(define version (database-schema-version db))
|
||||
(when (< version 1)
|
||||
(error 'migrate-database! "unable to determine the existing wiki database schema"))
|
||||
(when (= version 1)
|
||||
(migrate-1->2! db config))
|
||||
(define after-attachments (database-schema-version db))
|
||||
(when (= after-attachments 2)
|
||||
(migrate-2->3! db))
|
||||
(define after-todos (database-schema-version db))
|
||||
(when (= after-todos 3)
|
||||
(migrate-3->4! db))
|
||||
(define after-bookmarks (database-schema-version db))
|
||||
(when (= after-bookmarks 4)
|
||||
(migrate-4->5! db))
|
||||
(define after-todo-reindex (database-schema-version db))
|
||||
(when (= after-todo-reindex 5)
|
||||
(migrate-5->6! db))
|
||||
(define after-attachment-references (database-schema-version db))
|
||||
(when (= after-attachment-references 6)
|
||||
(migrate-6->7! db))
|
||||
(define after-namespaces (database-schema-version db))
|
||||
(when (= after-namespaces 7)
|
||||
(migrate-7->8! db))
|
||||
(define after-page-aliases (database-schema-version db))
|
||||
(when (= after-page-aliases 8)
|
||||
(migrate-8->9! db))
|
||||
(define after-concept-maps (database-schema-version db))
|
||||
(when (= after-concept-maps 9)
|
||||
(migrate-9->10! db))
|
||||
(define after-user-profiles (database-schema-version db))
|
||||
(when (= after-user-profiles 10)
|
||||
(migrate-10->11! db))
|
||||
(define after-concept-map-history (database-schema-version db))
|
||||
(when (= after-concept-map-history 11)
|
||||
(migrate-11->12! db))
|
||||
(define after-concept-map-history-cleanup (database-schema-version db))
|
||||
(when (= after-concept-map-history-cleanup 12)
|
||||
(migrate-12->13! db))
|
||||
(define after-people (database-schema-version db))
|
||||
(when (= after-people 13)
|
||||
(migrate-13->14! db))
|
||||
(define after-concept-definitions (database-schema-version db))
|
||||
(when (= after-concept-definitions 14)
|
||||
(migrate-14->15! db))
|
||||
(define after-submap-concepts (database-schema-version db))
|
||||
(when (= after-submap-concepts 15)
|
||||
(migrate-15->16! db))
|
||||
(define after-concept-link-aliases (database-schema-version db))
|
||||
(when (= after-concept-link-aliases 16)
|
||||
(migrate-16->17! db))
|
||||
(define after-concept-name-merge (database-schema-version db))
|
||||
(when (= after-concept-name-merge 17)
|
||||
(migrate-17->18! db))
|
||||
(define after-concept-normalization (database-schema-version db))
|
||||
(when (= after-concept-normalization 18)
|
||||
(migrate-18->19! db))
|
||||
(define after-placement-content-cleanup (database-schema-version db))
|
||||
(when (= after-placement-content-cleanup 19)
|
||||
(migrate-19->20! db))
|
||||
(define after-central-concept-references (database-schema-version db))
|
||||
(when (= after-central-concept-references 20)
|
||||
(migrate-20->21! db))
|
||||
(define resulting-version (database-schema-version db))
|
||||
(when (> resulting-version current-schema-version)
|
||||
(error 'migrate-database!
|
||||
"database schema ~a is newer than this racket-wiki supports (~a)"
|
||||
resulting-version
|
||||
current-schema-version))
|
||||
resulting-version)))
|
||||
(let loop ((version (database-schema-version db)))
|
||||
(cond
|
||||
((< version 1)
|
||||
(error 'migrate-database! "unable to determine the existing wiki database schema"))
|
||||
((= version 1) (migrate-1->2! db config) (loop (database-schema-version db)))
|
||||
((= version 2) (migrate-2->3! db) (loop (database-schema-version db)))
|
||||
((= version 3) (migrate-3->4! db) (loop (database-schema-version db)))
|
||||
((= version 4) (migrate-4->5! db) (loop (database-schema-version db)))
|
||||
((= version 5) (migrate-5->6! db) (loop (database-schema-version db)))
|
||||
((= version 6) (migrate-6->7! db) (loop (database-schema-version db)))
|
||||
((= version 7) (migrate-7->8! db) (loop (database-schema-version db)))
|
||||
((= version 8) (migrate-8->9! db) (loop (database-schema-version db)))
|
||||
((= version 9) (migrate-9->10! db) (loop (database-schema-version db)))
|
||||
((= version 10) (migrate-10->11! db) (loop (database-schema-version db)))
|
||||
((= version 11) (migrate-11->12! db) (loop (database-schema-version db)))
|
||||
((= version 12) (migrate-12->13! db) (loop (database-schema-version db)))
|
||||
((= version 13) (migrate-13->14! db) (loop (database-schema-version db)))
|
||||
((= version 14) (migrate-14->15! db) (loop (database-schema-version db)))
|
||||
((= version 15) (migrate-15->16! db) (loop (database-schema-version db)))
|
||||
((= version 16) (migrate-16->17! db) (loop (database-schema-version db)))
|
||||
((= version 17) (migrate-17->18! db) (loop (database-schema-version db)))
|
||||
((= version 18) (migrate-18->19! db) (loop (database-schema-version db)))
|
||||
((= version 19) (migrate-19->20! db) (loop (database-schema-version db)))
|
||||
((= version 20) (migrate-20->21! db) (loop (database-schema-version db)))
|
||||
((> version current-schema-version)
|
||||
(error 'migrate-database!
|
||||
"database schema ~a is newer than this racket-wiki supports (~a)"
|
||||
version
|
||||
current-schema-version))
|
||||
(else version))))))
|
||||
|
||||
Reference in New Issue
Block a user