236 lines
8.4 KiB
Racket
236 lines
8.4 KiB
Racket
#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)))))
|