Lots of changes to the cmap stuff
This commit is contained in:
@@ -0,0 +1,235 @@
|
||||
#lang racket/base
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Migrate document-internal CMap pages to shared stored views.
|
||||
;;
|
||||
;; The parent document remains the canonical graph. A stored child CMap only
|
||||
;; records which submap root it displays, so concepts, relations and layout
|
||||
;; contexts are never copied or removed from the parent.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require db
|
||||
json
|
||||
racket/cmdline
|
||||
racket/list
|
||||
racket/path
|
||||
racket/string
|
||||
"private/config.rkt"
|
||||
"private/database.rkt"
|
||||
"private/storage.rkt")
|
||||
|
||||
(define migration-author "system:cmap-shared-submap-migration")
|
||||
(define replaceable-authors
|
||||
'("system:cmap-subpage-migration" "system:cmap-subpage-migration-repair"))
|
||||
|
||||
(define (json-list document key)
|
||||
(define 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)
|
||||
|
||||
(define (legacy-submap? item)
|
||||
(and (equal? (hash-ref item 'kind "") "submap")
|
||||
(eq? (hash-ref item 'separateMap #f) #t)
|
||||
(let ((slug (hash-ref item 'cmapSlug 'null)))
|
||||
(or (eq? slug 'null)
|
||||
(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")))
|
||||
|
||||
(define (derived-document source-slug root-id)
|
||||
(hash 'schemaVersion 2
|
||||
'derivedView (hash 'sourceCmapSlug source-slug 'rootItemId root-id)
|
||||
'concepts '()
|
||||
'items '()
|
||||
'connectors '()
|
||||
'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))))
|
||||
|
||||
(define (load-parent-rows connection [lock? #f])
|
||||
(query-rows
|
||||
connection
|
||||
(string-append
|
||||
"SELECT id, slug, title, document::text, current_version "
|
||||
"FROM concept_maps WHERE archived=FALSE "
|
||||
"AND EXISTS (SELECT 1 FROM jsonb_array_elements("
|
||||
"CASE WHEN jsonb_typeof(document->'items')='array' "
|
||||
"THEN document->'items' ELSE '[]'::jsonb END) item "
|
||||
"WHERE coalesce(item->>'kind','')='submap' "
|
||||
"AND coalesce((item->>'separateMap')::boolean,FALSE)=TRUE "
|
||||
"AND coalesce(item->>'cmapSlug','')='') "
|
||||
"ORDER BY id"
|
||||
(if lock? " FOR UPDATE" ""))))
|
||||
|
||||
(define (existing-child connection slug [lock? #f])
|
||||
(query-maybe-row
|
||||
connection
|
||||
(string-append
|
||||
"SELECT id, title, current_version, created_by FROM concept_maps "
|
||||
"WHERE slug=$1 AND archived=FALSE"
|
||||
(if lock? " FOR UPDATE" ""))
|
||||
slug))
|
||||
|
||||
(define (replaceable-child? row)
|
||||
(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))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)
|
||||
|
||||
(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))))
|
||||
(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
|
||||
document-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',
|
||||
'Converted copied migration result into a canonical shared sub-CMap view',$6)
|
||||
SQL
|
||||
map-id next-version title document-text migration-author now))
|
||||
(let ((map-id
|
||||
(query-value
|
||||
connection
|
||||
#<<SQL
|
||||
INSERT INTO concept_maps
|
||||
(slug,title,document,current_version,created_at,updated_at,created_by,updated_by)
|
||||
VALUES ($1,$2,$3::text::jsonb,1,$4,$4,$5,$5)
|
||||
RETURNING id
|
||||
SQL
|
||||
(hash-ref child 'slug) (hash-ref child 'title)
|
||||
document-text now migration-author)))
|
||||
(query-exec
|
||||
connection
|
||||
#<<SQL
|
||||
INSERT INTO concept_map_versions
|
||||
(concept_map_id,version,title,document,author,action,summary,created_at)
|
||||
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))))
|
||||
|
||||
(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
|
||||
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
|
||||
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)))
|
||||
|
||||
(module+ main
|
||||
(define config (default-wiki-config))
|
||||
(define apply? #f)
|
||||
(command-line
|
||||
#:program "migrate-cmap-subpages.rkt"
|
||||
#:once-each
|
||||
(("--data") directory
|
||||
"Wiki data directory"
|
||||
(set! config
|
||||
(struct-copy wiki-config config
|
||||
(data-dir (path->complete-path directory)))))
|
||||
(("--apply")
|
||||
"Apply the migration; without this flag only a dry-run is performed"
|
||||
(set! apply? #t)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (connection)
|
||||
(if apply? (apply-migration! connection) (report-plan connection)))))
|
||||
Reference in New Issue
Block a user