refactoring by skill
This commit is contained in:
+87
-87
@@ -23,15 +23,15 @@
|
||||
'("system:cmap-subpage-migration" "system:cmap-subpage-migration-repair"))
|
||||
|
||||
(define (json-list document key)
|
||||
(define value (hash-ref document key '()))
|
||||
(if (list? value) value '()))
|
||||
(let ((value (hash-ref document key '())))
|
||||
(if (list? value) value '())))
|
||||
|
||||
(define (parse-document text)
|
||||
(define first (string->jsexpr text))
|
||||
(define document (if (string? first) (string->jsexpr first) first))
|
||||
(unless (hash? document)
|
||||
(error 'parse-document "stored CMap document is not an object"))
|
||||
document)
|
||||
(let* ((first (string->jsexpr text))
|
||||
(document (if (string? first) (string->jsexpr first) first)))
|
||||
(unless (hash? document)
|
||||
(error 'parse-document "stored CMap document is not an object"))
|
||||
document))
|
||||
|
||||
(define (legacy-submap? item)
|
||||
(and (equal? (hash-ref item 'kind "") "submap")
|
||||
@@ -41,13 +41,13 @@
|
||||
(and (string? slug) (string=? (string-trim slug) ""))))))
|
||||
|
||||
(define (submap-title item)
|
||||
(define child-map (hash-ref item 'childMap ""))
|
||||
(define label (hash-ref item 'label ""))
|
||||
(cond ((and (string? child-map) (not (string=? (string-trim child-map) "")))
|
||||
(string-trim child-map))
|
||||
((and (string? label) (not (string=? (string-trim label) "")))
|
||||
(string-trim label))
|
||||
(else "Sub-CMap")))
|
||||
(let ((child-map (hash-ref item 'childMap ""))
|
||||
(label (hash-ref item 'label "")))
|
||||
(cond ((and (string? child-map) (not (string=? (string-trim child-map) "")))
|
||||
(string-trim child-map))
|
||||
((and (string? label) (not (string=? (string-trim label) "")))
|
||||
(string-trim label))
|
||||
(else "Sub-CMap"))))
|
||||
|
||||
(define (derived-document source-slug root-id)
|
||||
(hash 'schemaVersion 2
|
||||
@@ -58,17 +58,17 @@
|
||||
'conceptMaps '()))
|
||||
|
||||
(define (link-parent-document document roots)
|
||||
(define slugs
|
||||
(for/hash ((root (in-list roots)))
|
||||
(values (hash-ref root 'id) (title->slug (submap-title root)))))
|
||||
(hash-set
|
||||
document
|
||||
'items
|
||||
(for/list ((item (in-list (json-list document 'items))))
|
||||
(define slug (hash-ref slugs (hash-ref item 'id #f) #f))
|
||||
(if slug
|
||||
(hash-set (hash-set item 'cmapSlug slug) 'separateMap #t)
|
||||
item))))
|
||||
(let ((slugs
|
||||
(for/hash ((root (in-list roots)))
|
||||
(values (hash-ref root 'id) (title->slug (submap-title root))))))
|
||||
(hash-set
|
||||
document
|
||||
'items
|
||||
(for/list ((item (in-list (json-list document 'items))))
|
||||
(let ((slug (hash-ref slugs (hash-ref item 'id #f) #f)))
|
||||
(if slug
|
||||
(hash-set (hash-set item 'cmapSlug slug) 'separateMap #t)
|
||||
item))))))
|
||||
|
||||
(define (load-parent-rows connection [lock? #f])
|
||||
(query-rows
|
||||
@@ -98,50 +98,50 @@
|
||||
(and row (member (vector-ref row 3) replaceable-authors)))
|
||||
|
||||
(define (check-child! connection parent-slug root [lock? #f])
|
||||
(define slug (title->slug (submap-title root)))
|
||||
(define row (existing-child connection slug lock?))
|
||||
(when (and row (not (replaceable-child? row)))
|
||||
(error 'migrate-cmap-subpages
|
||||
"target CMap ~a already exists and was not created by the earlier migration"
|
||||
slug))
|
||||
(hash 'slug slug
|
||||
'title (submap-title root)
|
||||
'rootId (hash-ref root 'id)
|
||||
'sourceSlug parent-slug
|
||||
'existing row))
|
||||
(let* ((slug (title->slug (submap-title root)))
|
||||
(row (existing-child connection slug lock?)))
|
||||
(when (and row (not (replaceable-child? row)))
|
||||
(error 'migrate-cmap-subpages
|
||||
"target CMap ~a already exists and was not created by the earlier migration"
|
||||
slug))
|
||||
(hash 'slug slug
|
||||
'title (submap-title root)
|
||||
'rootId (hash-ref root 'id)
|
||||
'sourceSlug parent-slug
|
||||
'existing row)))
|
||||
|
||||
(define (plans-for-row connection row [lock? #f])
|
||||
(define document (parse-document (vector-ref row 3)))
|
||||
(define roots (filter legacy-submap? (json-list document 'items)))
|
||||
(define children
|
||||
(for/list ((root (in-list roots)))
|
||||
(check-child! connection (vector-ref row 1) root lock?)))
|
||||
(values children (link-parent-document document roots)))
|
||||
(let* ((document (parse-document (vector-ref row 3)))
|
||||
(roots (filter legacy-submap? (json-list document 'items)))
|
||||
(children
|
||||
(for/list ((root (in-list roots)))
|
||||
(check-child! connection (vector-ref row 1) root lock?))))
|
||||
(values children (link-parent-document document roots))))
|
||||
|
||||
(define (report-plan connection)
|
||||
(define total 0)
|
||||
(for ((row (in-list (load-parent-rows connection))))
|
||||
(define-values (children ignored-parent) (plans-for-row connection row))
|
||||
(printf "Parent ~a (~a): ~a shared submap view(s)\n"
|
||||
(vector-ref row 1) (vector-ref row 2) (length children))
|
||||
(for ((child (in-list children)))
|
||||
(set! total (add1 total))
|
||||
(printf " ~a -> ~a (~a)\n"
|
||||
(hash-ref child 'title)
|
||||
(hash-ref child 'slug)
|
||||
(if (hash-ref child 'existing) "replace earlier migration result" "create"))))
|
||||
(printf "Total: ~a shared view(s). No data changed.\n" total)
|
||||
total)
|
||||
(let ((total 0))
|
||||
(for ((row (in-list (load-parent-rows connection))))
|
||||
(let-values (((children ignored-parent) (plans-for-row connection row)))
|
||||
(printf "Parent ~a (~a): ~a shared submap view(s)\n"
|
||||
(vector-ref row 1) (vector-ref row 2) (length children))
|
||||
(for ((child (in-list children)))
|
||||
(set! total (add1 total))
|
||||
(printf " ~a -> ~a (~a)\n"
|
||||
(hash-ref child 'title)
|
||||
(hash-ref child 'slug)
|
||||
(if (hash-ref child 'existing) "replace earlier migration result" "create")))))
|
||||
(printf "Total: ~a shared view(s). No data changed.\n" total)
|
||||
total))
|
||||
|
||||
(define (write-child! connection child now)
|
||||
(define document-text
|
||||
(jsexpr->string
|
||||
(derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId))))
|
||||
(define existing (hash-ref child 'existing))
|
||||
(if existing
|
||||
(let* ((map-id (vector-ref existing 0))
|
||||
(title (vector-ref existing 1))
|
||||
(next-version (add1 (vector-ref existing 2))))
|
||||
(let ((document-text
|
||||
(jsexpr->string
|
||||
(derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId))))
|
||||
(existing (hash-ref child 'existing)))
|
||||
(if existing
|
||||
(let* ((map-id (vector-ref existing 0))
|
||||
(title (vector-ref existing 1))
|
||||
(next-version (add1 (vector-ref existing 2))))
|
||||
(query-exec
|
||||
connection
|
||||
#<<SQL
|
||||
@@ -178,42 +178,42 @@ INSERT INTO concept_map_versions
|
||||
VALUES ($1,1,$2,$3::text::jsonb,$4,'shared-view-migration',
|
||||
'Created canonical shared sub-CMap view',$5)
|
||||
SQL
|
||||
map-id (hash-ref child 'title) document-text migration-author now))))
|
||||
map-id (hash-ref child 'title) document-text migration-author now)))))
|
||||
|
||||
(define (apply-migration! connection)
|
||||
(call-with-transaction
|
||||
connection
|
||||
(lambda ()
|
||||
(define now (current-seconds))
|
||||
(define total 0)
|
||||
(for ((row (in-list (load-parent-rows connection #t))))
|
||||
(define-values (children parent-document) (plans-for-row connection row #t))
|
||||
(for ((child (in-list children)))
|
||||
(write-child! connection child now)
|
||||
(set! total (add1 total)))
|
||||
(unless (null? children)
|
||||
(define map-id (vector-ref row 0))
|
||||
(define next-version (add1 (vector-ref row 4)))
|
||||
(define parent-text (jsexpr->string parent-document))
|
||||
(query-exec
|
||||
connection
|
||||
#<<SQL
|
||||
(λ ()
|
||||
(let ((now (current-seconds))
|
||||
(total 0))
|
||||
(for ((row (in-list (load-parent-rows connection #t))))
|
||||
(let-values (((children parent-document) (plans-for-row connection row #t)))
|
||||
(for ((child (in-list children)))
|
||||
(write-child! connection child now)
|
||||
(set! total (add1 total)))
|
||||
(unless (null? children)
|
||||
(let ((map-id (vector-ref row 0))
|
||||
(next-version (add1 (vector-ref row 4)))
|
||||
(parent-text (jsexpr->string parent-document)))
|
||||
(query-exec
|
||||
connection
|
||||
#<<SQL
|
||||
UPDATE concept_maps
|
||||
SET document=$1::text::jsonb, current_version=$2, updated_at=$3, updated_by=$4
|
||||
WHERE id=$5
|
||||
SQL
|
||||
parent-text next-version now migration-author map-id)
|
||||
(query-exec
|
||||
connection
|
||||
#<<SQL
|
||||
parent-text next-version now migration-author map-id)
|
||||
(query-exec
|
||||
connection
|
||||
#<<SQL
|
||||
INSERT INTO concept_map_versions
|
||||
(concept_map_id,version,title,document,author,action,summary,created_at)
|
||||
VALUES ($1,$2,$3,$4::text::jsonb,$5,'shared-view-migration',
|
||||
'Linked internal sub-CMaps to standalone shared views without moving graph data',$6)
|
||||
SQL
|
||||
map-id next-version (vector-ref row 2) parent-text migration-author now)))
|
||||
(printf "Migrated ~a submap(s) to shared stored views in one transaction.\n" total)
|
||||
total)))
|
||||
map-id next-version (vector-ref row 2) parent-text migration-author now)))))
|
||||
(printf "Migrated ~a submap(s) to shared stored views in one transaction.\n" total)
|
||||
total))))
|
||||
|
||||
(module+ main
|
||||
(define config (default-wiki-config))
|
||||
@@ -231,5 +231,5 @@ SQL
|
||||
(set! apply? #t)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (connection)
|
||||
(λ (connection)
|
||||
(if apply? (apply-migration! connection) (report-plan connection)))))
|
||||
|
||||
Reference in New Issue
Block a user