added mermaid and a lot of cmap changes

This commit is contained in:
2026-08-27 13:13:39 +02:00
parent 20c1584016
commit 2215d1d04a
35 changed files with 6442 additions and 350 deletions
+450 -27
View File
@@ -6,12 +6,17 @@
(require db
json
racket/list
racket/string
"concept-id.rkt"
"database.rkt"
"people.rkt"
"storage.rkt")
(provide list-concept-maps
list-archived-concept-maps
list-concept-usage
list-concept-todos
list-recent-concept-maps
search-concept-maps
read-concept-map
@@ -21,7 +26,8 @@
create-concept-map!
rename-concept-map!
update-concept-map!
archive-concept-map!)
archive-concept-map!
restore-concept-map!)
(define maximum-document-size (* 10 1024 1024))
@@ -51,6 +57,210 @@
(error 'text->document "stored concept map document is not a JSON object"))
document))
(define (document-concepts document)
(define concepts (hash-ref document 'concepts '()))
(if (list? concepts) concepts '()))
(define concept-content-keys
'(id label synopsis aspects tags descriptionPageSlug pageSlug cmapSlug externalUrl
imageSource))
(define placement-content-keys
'(label synopsis aspects tags descriptionPageSlug pageSlug cmapSlug externalUrl
imageSource))
(define (valid-external-url? value)
(and (string? value)
(regexp-match? #px"(?i:^https?://[^\\s]+$)" value)))
(define (concept-content concept)
(when (and (hash-has-key? concept 'externalUrl)
(let ([value (hash-ref concept 'externalUrl)])
(and value
(not (eq? value 'null))
(not (and (string? value) (string=? value "")))
(not (valid-external-url? value)))))
(error 'concept-content "externalUrl must be a complete http or https URL"))
(for/fold ([content (hash)]) ([key (in-list concept-content-keys)]
#:when (hash-has-key? concept key))
(hash-set content key
(if (eq? key 'tags)
(let ([tags (hash-ref concept key)])
(if (list? tags)
(filter (λ (tag)
(and (hash? tag)
(equal? (hash-ref tag 'type #f) "person")))
tags)
'()))
(hash-ref concept key)))))
(define (document-item-concept-ids document)
(remove-duplicates
(for/list ([item (in-list (let ([items (hash-ref document 'items '())])
(if (list? items) items '())))]
#:when (and (hash? item)
(string? (hash-ref item 'conceptId #f))
(not (equal? (hash-ref item 'kind "concept") "phrase"))))
(hash-ref item 'conceptId))))
(define (remove-hash-keys value keys)
(for/fold ([result value]) ([key (in-list keys)])
(hash-remove result key)))
;; A persisted CMap owns structure and presentation only. Full concept content
;; is stored once, in concept_definitions. The concepts array is retained as an
;; explicit set of references so the JSON document remains self-describing.
(define (concept-map-storage-document document)
(define items (hash-ref document 'items '()))
(define placement-items
(for/list ([item (in-list (if (list? items) items '()))])
(if (and (hash? item)
(not (equal? (hash-ref item 'kind "concept") "phrase")))
(remove-hash-keys item placement-content-keys)
item)))
(define concept-ids
(remove-duplicates
(append
(for/list ([concept (in-list (document-concepts document))]
#:when (and (hash? concept)
(string? (hash-ref concept 'id #f))
(not (string=? (hash-ref concept 'id) ""))))
(hash-ref concept 'id))
(document-item-concept-ids document))))
(for ([concept-id (in-list concept-ids)])
(unless (concept-id? concept-id)
(error 'concept-map-storage-document "invalid concept UUID: ~a" concept-id)))
(hash-set
(hash-set document 'items placement-items)
'concepts
(for/list ([concept-id (in-list concept-ids)])
(hash 'id concept-id))))
(define (concept-definition-by-id db concept-id)
(define row
(query-maybe-row
db
"SELECT document::text FROM concept_definitions WHERE id = $1"
concept-id))
(and row (concept-content (text->document (vector-ref row 0)))))
(define (document-concept-id-map db document)
(define concepts-by-id
(for/hash ([concept (in-list (document-concepts document))]
#:when (and (hash? concept) (string? (hash-ref concept 'id #f))))
(values (hash-ref concept 'id) concept)))
(define items (hash-ref document 'items '()))
(define sources
(append
(document-concepts document)
(for/list ([item (in-list (if (list? items) items '()))]
#:when (and (hash? item) (string? (hash-ref item 'conceptId #f))))
(hash-set item 'id (hash-ref item 'conceptId)))))
(define by-name (make-hash))
(for/fold ([by-id (hash)]) ([source (in-list sources)]
#:when (and (hash? source)
(string? (hash-ref source 'id #f))))
(define concept-id (hash-ref source 'id))
(define repository-concept (hash-ref concepts-by-id concept-id #f))
(define label
(cond [(and repository-concept (string? (hash-ref repository-concept 'label #f)))
(hash-ref repository-concept 'label)]
[(string? (hash-ref source 'label #f)) (hash-ref source 'label)]
[else ""]))
(define name-key (string-downcase (string-trim label)))
(define stored-id
(and (not (string=? name-key ""))
(query-maybe-value
db
#<<SQL
SELECT id
FROM concept_definitions
WHERE lower(trim(document ->> 'label')) = $1
ORDER BY updated_at DESC, id DESC
LIMIT 1
SQL
name-key)))
(define canonical-id
(or stored-id
(and (not (string=? name-key "")) (hash-ref by-name name-key #f))
(hash-ref by-id concept-id #f)
(normalized-or-new-concept-id concept-id)))
(unless (string=? name-key "") (hash-set! by-name name-key canonical-id))
(hash-set by-id concept-id canonical-id)))
(define (canonicalize-document-concepts db document)
(define id-map (document-concept-id-map db document))
(define canonical-concepts
(for/fold ([by-id (hash)]) ([concept (in-list (document-concepts document))]
#:when (and (hash? concept)
(string? (hash-ref concept 'id #f))))
(define original-id (hash-ref concept 'id))
(define canonical-id (hash-ref id-map original-id original-id))
(define stored-definition
(and (not (string=? canonical-id original-id))
(concept-definition-by-id db canonical-id)))
(hash-set by-id canonical-id
(hash-set (or stored-definition (concept-content concept))
'id canonical-id))))
(define items (hash-ref document 'items '()))
(define canonical-items
(for/list ([item (in-list (if (list? items) items '()))])
(define concept-id (and (hash? item) (hash-ref item 'conceptId #f)))
(if (string? concept-id)
(hash-set item 'conceptId (hash-ref id-map concept-id concept-id))
item)))
(hash-set (hash-set document 'concepts (hash-values canonical-concepts))
'items canonical-items))
;; Content belongs to a concept, not to one of its placements. Position, size,
;; colour and typography remain in the CMap item/layout document.
(define (sync-concept-definitions! db document author now)
(for ([concept (in-list (document-concepts document))]
#:when (and (hash? concept)
(string? (hash-ref concept 'id #f))
(not (string=? (hash-ref concept 'id) ""))))
(unless (concept-id? (hash-ref concept 'id))
(error 'sync-concept-definitions! "invalid concept UUID: ~a"
(hash-ref concept 'id)))
(query-exec
db
#<<SQL
INSERT INTO concept_definitions(id, document, updated_at, updated_by)
VALUES ($1, $2::text::jsonb, $3, $4)
ON CONFLICT (id) DO UPDATE
SET document = EXCLUDED.document,
updated_at = EXCLUDED.updated_at,
updated_by = EXCLUDED.updated_by
SQL
(hash-ref concept 'id)
(document->text (concept-content concept))
now
author)))
(define (hydrate-concept-definitions db document)
(define canonical-document (canonicalize-document-concepts db document))
(define local-concepts
(for/hash ([concept (in-list (document-concepts canonical-document))]
#:when (and (hash? concept) (string? (hash-ref concept 'id #f))))
(values (hash-ref concept 'id) (concept-content concept))))
(define concept-ids
(remove-duplicates
(append (hash-keys local-concepts) (document-item-concept-ids canonical-document))))
(define hydrated
(for/list ([concept-id (in-list concept-ids)])
(define row
(query-maybe-row
db
"SELECT document::text FROM concept_definitions WHERE id = $1"
concept-id))
(if row
(concept-content (text->document (vector-ref row 0)))
(hash-ref local-concepts concept-id (hash 'id concept-id)))))
;; Sanitize legacy documents on the read path too. An editor can therefore
;; never receive item-level content that competes with the central record.
(hash-set (concept-map-storage-document canonical-document)
'concepts hydrated))
(define (row->concept-map row [include-document? #t])
(define result
(hash 'slug (vector-ref row 0)
@@ -119,6 +329,37 @@ SQL
" ORDER BY lower(title), title")))))
(row->concept-map row #f)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List archived concept-map metadata for administration.
; pre : Database schema migration 9 has been installed.
; post : No database state is changed and documents are not transferred.
; result : A newest-archived-first list including archive audit fields.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-archived-concept-maps config)
(call-with-wiki-database
config
(λ (db)
(for/list ((row (in-list
(query-rows
db
#<<SQL
SELECT slug, title, document::text, current_version,
created_at, updated_at, created_by, updated_by,
archived_at, archived_by
FROM concept_maps
WHERE archived = TRUE
ORDER BY archived_at DESC, lower(title), title
SQL
))))
(hash-set
(hash-set (row->concept-map row #f)
'archivedAt (if (sql-null? (vector-ref row 8))
'null
(vector-ref row 8)))
'archivedBy (or (and (not (sql-null? (vector-ref row 9)))
(vector-ref row 9))
""))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Count current concept placements across every active CMap.
; pre : Concept-map documents use an items array when placements exist.
@@ -137,15 +378,13 @@ SQL
WITH placements AS (
SELECT cm.slug,
cm.title AS cmap_title,
CASE
WHEN item ->> 'conceptId' ~ '^concept-[0-9]+$'
THEN concat('legacy:', cm.slug, ':', item ->> 'conceptId')
ELSE item ->> 'conceptId'
END AS concept_id,
coalesce(nullif(repository.document ->> 'label', ''),
item ->> 'conceptId' AS concept_id,
coalesce(nullif(definition.document ->> 'label', ''),
nullif(repository.document ->> 'label', ''),
nullif(item ->> 'label', ''),
'Concept') AS concept_label,
coalesce(nullif(repository.document ->> 'pageSlug', ''),
coalesce(nullif(definition.document ->> 'pageSlug', ''),
nullif(repository.document ->> 'pageSlug', ''),
nullif(item ->> 'pageSlug', '')) AS page_slug
FROM concept_maps cm
CROSS JOIN LATERAL jsonb_array_elements(
@@ -167,9 +406,11 @@ WITH placements AS (
WHERE concept_value ->> 'id' = item ->> 'conceptId'
LIMIT 1
) repository ON TRUE
LEFT JOIN concept_definitions definition
ON definition.id = item ->> 'conceptId'
WHERE cm.archived = FALSE
AND nullif(item ->> 'conceptId', '') IS NOT NULL
AND coalesce(item ->> 'kind', 'concept') NOT IN ('phrase', 'submap')
AND coalesce(item ->> 'kind', 'concept') <> 'phrase'
)
SELECT concept_id, slug, cmap_title, concept_label, page_slug, count(*)
FROM placements
@@ -186,6 +427,70 @@ SQL
(vector-ref row 4))
'count (vector-ref row 5))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List globally defined concepts carrying the TODO aspect.
; pre : Concept definitions and current CMap documents are available.
; post : No database state is changed and every concept occurs at most once.
; result : Concept todo hashes with shared content and a current map location.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-concept-todos config)
(call-with-wiki-database
config
(λ (db)
(for/list ([row (in-list
(query-rows
db
#<<SQL
SELECT definition.id,
coalesce(nullif(definition.document ->> 'label', ''), 'Concept') AS label,
coalesce(definition.document ->> 'synopsis', '') AS synopsis,
nullif(definition.document ->> 'descriptionPageSlug', '') AS description_page_slug,
nullif(definition.document ->> 'pageSlug', '') AS page_slug,
nullif(definition.document ->> 'cmapSlug', '') AS linked_cmap_slug,
nullif(definition.document ->> 'externalUrl', '') AS external_url,
placement.cmap_slug,
placement.cmap_title
FROM concept_definitions definition
JOIN LATERAL (
SELECT cm.slug AS cmap_slug, cm.title AS cmap_title
FROM concept_maps cm
CROSS JOIN LATERAL jsonb_array_elements(
CASE WHEN jsonb_typeof(cm.document -> 'items') = 'array'
THEN cm.document -> 'items' ELSE '[]'::jsonb END
) AS item
WHERE cm.archived = FALSE
AND item ->> 'conceptId' = definition.id
AND coalesce(item ->> 'kind', 'concept') <> 'phrase'
ORDER BY lower(cm.title), cm.title, cm.slug
LIMIT 1
) placement ON TRUE
WHERE EXISTS (
SELECT 1
FROM jsonb_array_elements_text(
CASE WHEN jsonb_typeof(definition.document -> 'aspects') = 'array'
THEN definition.document -> 'aspects' ELSE '[]'::jsonb END
) AS aspect(value)
WHERE lower(trim(aspect.value)) = 'todo'
)
ORDER BY lower(coalesce(definition.document ->> 'label', '')),
coalesce(definition.document ->> 'label', ''),
definition.id
SQL
))])
(define (nullable index)
(define value (vector-ref row index))
(if (sql-null? value) 'null value))
(hash 'type "concept"
'conceptId (vector-ref row 0)
'title (vector-ref row 1)
'text (vector-ref row 2)
'descriptionPageSlug (nullable 3)
'pageSlug (nullable 4)
'cmapSlug (nullable 5)
'externalUrl (nullable 6)
'placementCmapSlug (vector-ref row 7)
'placementCmapTitle (vector-ref row 8))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List recently edited current concept maps.
; pre : Database schema migration 9 has been installed.
@@ -230,14 +535,17 @@ WITH q AS (
cm.title,
coalesce((
SELECT string_agg(
concat_ws(' ', item ->> 'label', item ->> 'synopsis'),
concat_ws(' ', coalesce(definition.document, concept) ->> 'label',
coalesce(definition.document, concept) ->> 'synopsis'),
' ')
FROM jsonb_array_elements(
CASE
WHEN jsonb_typeof(cm.document -> 'items') = 'array'
THEN cm.document -> 'items'
WHEN jsonb_typeof(cm.document -> 'concepts') = 'array'
THEN cm.document -> 'concepts'
ELSE '[]'::jsonb
END) AS item
END) AS concept
LEFT JOIN concept_definitions definition
ON definition.id = concept ->> 'id'
), '') AS concept_text
FROM concept_maps cm
WHERE cm.archived = FALSE
@@ -288,7 +596,11 @@ SQL
"SELECT " concept-map-columns
" FROM concept_maps WHERE slug = $1 AND archived = FALSE")
slug))
(if row (row->concept-map row) #f)))))
(if row
(hash-update (row->concept-map row)
'document
(λ (document) (hydrate-concept-definitions db document)))
#f)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a persistent concept map.
@@ -301,7 +613,6 @@ SQL
(define clean-slug (string-trim slug))
(define clean-title (string-trim title))
(validate-concept-map-input 'create-concept-map! clean-slug clean-title document)
(define document-text (document->text document))
(define now (current-seconds))
(call-with-wiki-database
config
@@ -309,6 +620,11 @@ SQL
(call-with-transaction
db
(λ ()
(define canonical-document (canonicalize-document-concepts db document))
(define document-text
(document->text (concept-map-storage-document canonical-document)))
(sync-concept-definitions! db canonical-document author now)
(sync-person-tags! db canonical-document)
(query-value
db
#<<SQL
@@ -384,7 +700,6 @@ SQL
(error 'update-concept-map! "invalid save action: ~a" action))
(define clean-title (string-trim title))
(validate-concept-map-input 'update-concept-map! slug clean-title document)
(define document-text (document->text document))
(call-with-wiki-database
config
(λ (db)
@@ -407,6 +722,10 @@ SQL
(error 'update-concept-map! "version-conflict"))
(define next-version (+ current-version 1))
(define now (current-seconds))
(define canonical-document (canonicalize-document-concepts db document))
(define document-text
(document->text (concept-map-storage-document canonical-document)))
(sync-concept-definitions! db canonical-document author now)
(query-exec
db
#<<SQL
@@ -424,6 +743,7 @@ SQL
now
author
(vector-ref row 0))
(sync-person-tags! db canonical-document)
(unless (string=? action "autosave")
(insert-concept-map-version!
db (vector-ref row 0) next-version clean-title document-text
@@ -528,24 +848,127 @@ SQL
#t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Soft-delete one concept map.
; pre : slug identifies a current map.
; post : The map is excluded from normal list/read operations.
; goal : Archive one concept map after explicit identity confirmation.
; pre : slug, exact title and base-version identify the current map.
; post : The map is excluded from normal list/read operations atomically.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (archive-concept-map! config slug author)
(define (archive-concept-map! config slug expected-title author base-version)
(call-with-wiki-database
config
(λ (db)
(define changed
(query-exec
db
#<<SQL
(call-with-transaction
db
(λ ()
(define row
(query-maybe-row
db
"SELECT id, title, current_version FROM concept_maps WHERE slug = $1 AND archived = FALSE FOR UPDATE"
slug))
(unless row
(error 'archive-concept-map! "unknown concept map: ~a" slug))
(unless (and (string? expected-title)
(string=? expected-title (vector-ref row 1)))
(error 'archive-concept-map! "title-confirmation-mismatch"))
(define supplied-version
(if (number? base-version)
base-version
(string->number (format "~a" base-version))))
(unless (and supplied-version (= supplied-version (vector-ref row 2)))
(error 'archive-concept-map! "version-conflict"))
(define now (current-seconds))
(query-exec
db
#<<SQL
UPDATE concept_maps
SET archived = TRUE, archived_at = $1, archived_by = $2,
updated_at = $1, updated_by = $2
WHERE slug = $3 AND archived = FALSE
WHERE id = $3
SQL
now author (vector-ref row 0))))))
(void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Restore one archived concept map.
; pre : slug identifies an archived map.
; post : Archive markers are cleared; content, version and history survive.
; result : The restored current concept-map hash.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (restore-concept-map! config slug author)
(call-with-wiki-database
config
(λ (db)
(define restored-id
(query-maybe-value
db
#<<SQL
UPDATE concept_maps
SET archived = FALSE, archived_at = NULL, archived_by = NULL,
updated_at = $1, updated_by = $2
WHERE slug = $3 AND archived = TRUE
RETURNING id
SQL
(current-seconds) author slug))
(void changed)))
(void))
(unless restored-id
(error 'restore-concept-map! "unknown archived concept map: ~a" slug))))
(read-concept-map config slug))
(module+ test
(require rackunit)
(define concept-a "11111111-1111-4111-8111-111111111111")
(define concept-b "22222222-2222-4222-8222-222222222222")
(define stored-document
(concept-map-storage-document
(hash 'metadata (hash 'summary "Map summary")
'concepts (list (hash 'id concept-a
'label "Shared concept"
'synopsis "Central content"))
'items (list (hash 'id 1
'conceptId concept-a
'kind "submap"
'label "Stale item label"
'synopsis "Stale item content"
'externalUrl "https://example.com/shared"
'x 40
'backgroundColor "#ffffff")
(hash 'id 2
'conceptId concept-b
'kind "concept"
'label "Item-only concept")
(hash 'id 3
'kind "phrase"
'label "relates to")))))
(check-equal? (hash-ref stored-document 'concepts)
(list (hash 'id concept-a) (hash 'id concept-b)))
(define stored-items (hash-ref stored-document 'items))
(check-false (hash-has-key? (first stored-items) 'label))
(check-false (hash-has-key? (first stored-items) 'synopsis))
(check-false (hash-has-key? (first stored-items) 'externalUrl))
(check-equal? (hash-ref (first stored-items) 'x) 40)
(check-equal? (hash-ref (first stored-items) 'backgroundColor) "#ffffff")
(check-equal? (hash-ref (third stored-items) 'label) "relates to")
(check-equal? (hash-ref (hash-ref stored-document 'metadata) 'summary)
"Map summary")
(check-true (concept-id? concept-a))
(check-true (concept-id? "A3C4F0D1-22E5-4C42-9A40-CC864993F785"))
(check-false (concept-id? "concept-a"))
(check-equal? (hash-ref (concept-content
(hash 'id concept-a
'label "Linked concept"
'externalUrl "https://example.com/path"))
'externalUrl)
"https://example.com/path")
(check-exn exn:fail?
(lambda ()
(concept-content
(hash 'id concept-a
'label "Unsafe concept"
'externalUrl "javascript:alert(1)"))))
(check-exn exn:fail?
(lambda ()
(concept-map-storage-document
(hash 'concepts (list (hash 'id "legacy:map:concept-1"))
'items '())))))