1150 lines
46 KiB
Racket
1150 lines
46 KiB
Racket
#lang racket/base
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PostgreSQL-backed concept-map storage.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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
|
|
concept-map-history
|
|
read-concept-map-version
|
|
delete-concept-map-version!
|
|
create-concept-map!
|
|
rename-concept-map!
|
|
update-concept-map!
|
|
archive-concept-map!
|
|
restore-concept-map!)
|
|
|
|
(define maximum-document-size (* 10 1024 1024))
|
|
|
|
(define concept-map-columns
|
|
"slug, title, document::text, current_version, created_at, updated_at, created_by, updated_by")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Concept-map documents and shared concept definitions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Encodes a CMap document as size-limited JSON text for PostgreSQL.
|
|
(define (document->text document)
|
|
(unless (jsexpr? document)
|
|
(raise-argument-error 'document->text "jsexpr?" document))
|
|
(let ((text (jsexpr->string document)))
|
|
(when (> (bytes-length (string->bytes/utf-8 text)) maximum-document-size)
|
|
(error 'document->text "concept map document exceeds 10 MiB"))
|
|
text))
|
|
|
|
;;; Decodes a stored JSON object, including documents encoded twice by older versions.
|
|
(define (text->document text)
|
|
(with-handlers ((exn:fail?
|
|
(λ (e)
|
|
(error 'text->document
|
|
"invalid stored concept map document: ~a"
|
|
(exn-message e)))))
|
|
(let* ((parsed (string->jsexpr text))
|
|
(document (if (string? parsed)
|
|
(string->jsexpr parsed)
|
|
parsed)))
|
|
(unless (hash? document)
|
|
(error 'text->document "stored concept map document is not a JSON object"))
|
|
document)))
|
|
|
|
;;; Returns the concepts array, treating a malformed or absent value as empty.
|
|
(define (document-concepts document)
|
|
(let ((concepts (hash-ref document 'concepts '())))
|
|
(if (list? concepts) concepts '())))
|
|
|
|
;;; Returns the items array, treating a malformed or absent value as empty.
|
|
(define (document-items document)
|
|
(let ((items (hash-ref document 'items '())))
|
|
(if (list? items) items '())))
|
|
|
|
(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))
|
|
|
|
;;; Recognizes complete HTTP and HTTPS links accepted as shared concept content.
|
|
(define (valid-external-url? value)
|
|
(and (string? value)
|
|
(regexp-match? #px"(?i:^https?://[^\\s]+$)" value)))
|
|
|
|
;;; Selects and sanitizes the part of a concept stored in concept_definitions.
|
|
(define (concept-content concept)
|
|
(let* ((has-external-url? (hash-has-key? concept 'externalUrl))
|
|
(external-url (hash-ref concept 'externalUrl #f)))
|
|
(when (and has-external-url?
|
|
external-url
|
|
(not (eq? external-url 'null))
|
|
(not (equal? external-url ""))
|
|
(not (valid-external-url? external-url)))
|
|
(error 'concept-content "externalUrl must be a complete http or https URL"))
|
|
(let copy-content ((keys concept-content-keys)
|
|
(content (hash)))
|
|
(cond
|
|
((null? keys) content)
|
|
((not (hash-has-key? concept (car keys)))
|
|
(copy-content (cdr keys) content))
|
|
(else
|
|
(let* ((key (car keys))
|
|
(value (hash-ref concept key))
|
|
(tags? (eq? key 'tags))
|
|
(stored-value
|
|
(cond
|
|
((not tags?) value)
|
|
((list? value)
|
|
(filter (λ (tag)
|
|
(and (hash? tag)
|
|
(equal? (hash-ref tag 'type #f) "person")))
|
|
value))
|
|
(else '()))))
|
|
(copy-content (cdr keys) (hash-set content key stored-value))))))))
|
|
|
|
;;; Recognizes a non-phrase item that refers to a concept by string identifier.
|
|
(define (concept-placement? item)
|
|
(and (hash? item)
|
|
(string? (hash-ref item 'conceptId #f))
|
|
(not (equal? (hash-ref item 'kind "concept") "phrase"))))
|
|
|
|
;;; Returns every distinct concept identifier referenced by document placements.
|
|
(define (document-item-concept-ids document)
|
|
(remove-duplicates
|
|
(map (λ (item) (hash-ref item 'conceptId))
|
|
(filter concept-placement? (document-items document)))))
|
|
|
|
;;; Removes the supplied keys from an immutable hash.
|
|
(define (remove-hash-keys value keys)
|
|
(foldl (λ (key result) (hash-remove result key)) value keys))
|
|
|
|
;; 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.
|
|
;;; Reduces an editor document to placement data and shared-concept references.
|
|
(define (concept-map-storage-document document)
|
|
(let* ((placement-items
|
|
(map (λ (item)
|
|
(if (and (hash? item)
|
|
(not (equal? (hash-ref item 'kind "concept") "phrase")))
|
|
(remove-hash-keys item placement-content-keys)
|
|
item))
|
|
(document-items document)))
|
|
(defined-concept-ids
|
|
(map (λ (concept) (hash-ref concept 'id))
|
|
(filter (λ (concept)
|
|
(and (hash? concept)
|
|
(string? (hash-ref concept 'id #f))
|
|
(not (string=? (hash-ref concept 'id) ""))))
|
|
(document-concepts document))))
|
|
(concept-ids
|
|
(remove-duplicates
|
|
(append defined-concept-ids (document-item-concept-ids document)))))
|
|
(for-each
|
|
(λ (concept-id)
|
|
(unless (concept-id? concept-id)
|
|
(error 'concept-map-storage-document "invalid concept UUID: ~a" concept-id)))
|
|
concept-ids)
|
|
(hash-set (hash-set document 'items placement-items)
|
|
'concepts
|
|
(map (λ (concept-id) (hash 'id concept-id)) concept-ids))))
|
|
|
|
;;; Reads and sanitizes one shared concept definition by its canonical UUID.
|
|
(define (concept-definition-by-id db concept-id)
|
|
(let ((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)))
|
|
#f)))
|
|
|
|
;;; Chooses the best available label for matching a source to a shared concept.
|
|
(define (concept-source-label source repository-concept)
|
|
(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 "")))
|
|
|
|
;;; Finds the most recently updated shared concept with the normalized label.
|
|
(define (concept-id-by-label db name-key)
|
|
(if (string=? name-key "")
|
|
#f
|
|
(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)))
|
|
|
|
;;; Maps document-local concept identifiers to canonical shared identifiers.
|
|
(define (document-concept-id-map db document)
|
|
(let* ((concepts
|
|
(filter (λ (concept)
|
|
(and (hash? concept) (string? (hash-ref concept 'id #f))))
|
|
(document-concepts document)))
|
|
(concepts-by-id
|
|
(foldl (λ (concept result)
|
|
(hash-set result (hash-ref concept 'id) concept))
|
|
(hash)
|
|
concepts))
|
|
(item-sources
|
|
(map (λ (item) (hash-set item 'id (hash-ref item 'conceptId)))
|
|
(filter (λ (item)
|
|
(and (hash? item)
|
|
(string? (hash-ref item 'conceptId #f))))
|
|
(document-items document))))
|
|
(sources (append (document-concepts document) item-sources))
|
|
(valid-sources
|
|
(filter (λ (source)
|
|
(and (hash? source) (string? (hash-ref source 'id #f))))
|
|
sources)))
|
|
(let map-identifiers ((remaining valid-sources)
|
|
(by-id (hash))
|
|
(by-name (hash)))
|
|
(if (null? remaining)
|
|
by-id
|
|
(let* ((source (car remaining))
|
|
(concept-id (hash-ref source 'id))
|
|
(repository-concept (hash-ref concepts-by-id concept-id #f))
|
|
(label (concept-source-label source repository-concept))
|
|
(name-key (string-downcase (string-trim label)))
|
|
(stored-id (concept-id-by-label db name-key))
|
|
(known-name-id
|
|
(if (string=? name-key "") #f (hash-ref by-name name-key #f)))
|
|
(canonical-id
|
|
(or stored-id
|
|
known-name-id
|
|
(hash-ref by-id concept-id #f)
|
|
(normalized-or-new-concept-id concept-id)))
|
|
(next-by-name
|
|
(if (string=? name-key "")
|
|
by-name
|
|
(hash-set by-name name-key canonical-id))))
|
|
(map-identifiers (cdr remaining)
|
|
(hash-set by-id concept-id canonical-id)
|
|
next-by-name))))))
|
|
|
|
;;; Rewrites repository concepts and placements to their canonical identifiers.
|
|
(define (canonicalize-document-concepts db document)
|
|
(let* ((id-map (document-concept-id-map db document))
|
|
(concepts
|
|
(filter (λ (concept)
|
|
(and (hash? concept) (string? (hash-ref concept 'id #f))))
|
|
(document-concepts document)))
|
|
(canonical-concepts
|
|
(foldl
|
|
(λ (concept by-id)
|
|
(let* ((original-id (hash-ref concept 'id))
|
|
(canonical-id (hash-ref id-map original-id original-id))
|
|
(stored-definition
|
|
(and (not (string=? canonical-id original-id))
|
|
(concept-definition-by-id db canonical-id)))
|
|
(content (or stored-definition (concept-content concept))))
|
|
(hash-set by-id canonical-id (hash-set content 'id canonical-id))))
|
|
(hash)
|
|
concepts))
|
|
(canonical-items
|
|
(map (λ (item)
|
|
(let ((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)))
|
|
(document-items document))))
|
|
(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.
|
|
;;; Inserts or updates the canonical definition of every concept in a document.
|
|
(define (sync-concept-definitions! db document author now)
|
|
(let ((concepts
|
|
(filter (λ (concept)
|
|
(and (hash? concept)
|
|
(string? (hash-ref concept 'id #f))
|
|
(not (string=? (hash-ref concept 'id) ""))))
|
|
(document-concepts document))))
|
|
(for-each
|
|
(λ (concept)
|
|
(let ((concept-id (hash-ref concept 'id)))
|
|
(unless (concept-id? concept-id)
|
|
(error 'sync-concept-definitions! "invalid concept UUID: ~a" 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
|
|
concept-id
|
|
(document->text (concept-content concept))
|
|
now
|
|
author)))
|
|
concepts)))
|
|
|
|
;;; Replaces stored references with canonical concept definitions for the editor.
|
|
(define (hydrate-concept-definitions db document)
|
|
(let* ((canonical-document (canonicalize-document-concepts db document))
|
|
(local-concepts
|
|
(foldl
|
|
(λ (concept result)
|
|
(if (and (hash? concept) (string? (hash-ref concept 'id #f)))
|
|
(hash-set result
|
|
(hash-ref concept 'id)
|
|
(concept-content concept))
|
|
result))
|
|
(hash)
|
|
(document-concepts canonical-document)))
|
|
(concept-ids
|
|
(remove-duplicates
|
|
(append (hash-keys local-concepts)
|
|
(document-item-concept-ids canonical-document))))
|
|
(hydrated
|
|
(map (λ (concept-id)
|
|
(let ((definition (concept-definition-by-id db concept-id)))
|
|
(or definition
|
|
(hash-ref local-concepts concept-id (hash 'id concept-id)))))
|
|
concept-ids)))
|
|
;; 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)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Database rows and write support
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Converts a concept_maps result row to the hash returned by this module.
|
|
(define (row->concept-map row [include-document? #t])
|
|
(let ((result
|
|
(hash 'slug (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'currentVersion (vector-ref row 3)
|
|
'createdAt (vector-ref row 4)
|
|
'updatedAt (vector-ref row 5)
|
|
'createdBy (vector-ref row 6)
|
|
'updatedBy (vector-ref row 7))))
|
|
(if include-document?
|
|
(hash-set result 'document (text->document (vector-ref row 2)))
|
|
result)))
|
|
|
|
;;; Converts SQL NULL to JSON null and otherwise returns the selected row value.
|
|
(define (nullable-row-value row index)
|
|
(let ((value (vector-ref row index)))
|
|
(if (sql-null? value) 'null value)))
|
|
|
|
;;; Extends concept-map metadata with the administrative archive audit fields.
|
|
(define (row->archived-concept-map row)
|
|
(hash-set (hash-set (row->concept-map row #f)
|
|
'archivedAt (nullable-row-value row 8))
|
|
'archivedBy (let ((value (nullable-row-value row 9)))
|
|
(if (eq? value 'null) "" value))))
|
|
|
|
;;; Converts one grouped placement row to a concept-usage result.
|
|
(define (row->concept-usage row)
|
|
(hash 'conceptId (vector-ref row 0)
|
|
'cmapSlug (vector-ref row 1)
|
|
'cmapTitle (vector-ref row 2)
|
|
'label (vector-ref row 3)
|
|
'pageSlug (nullable-row-value row 4)
|
|
'count (vector-ref row 5)))
|
|
|
|
;;; Converts a shared TODO concept and its representative placement to JSON data.
|
|
(define (row->concept-todo row)
|
|
(hash 'type "concept"
|
|
'conceptId (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'text (vector-ref row 2)
|
|
'descriptionPageSlug (nullable-row-value row 3)
|
|
'pageSlug (nullable-row-value row 4)
|
|
'cmapSlug (nullable-row-value row 5)
|
|
'externalUrl (nullable-row-value row 6)
|
|
'placementCmapSlug (vector-ref row 7)
|
|
'placementCmapTitle (vector-ref row 8)))
|
|
|
|
;;; Converts one full-text query row to the result shape shared with wiki search.
|
|
(define (row->search-result row)
|
|
(hash 'slug (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'rank (vector-ref row 2)
|
|
'snippet (vector-ref row 3)
|
|
'type "cmap"))
|
|
|
|
;;; Converts one user-visible version row to history metadata.
|
|
(define (row->history-entry row)
|
|
(hash 'version (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'author (vector-ref row 2)
|
|
'action (vector-ref row 3)
|
|
'summary (vector-ref row 4)
|
|
'createdAt (vector-ref row 5)))
|
|
|
|
;;; Converts one immutable version row to metadata plus its editor document.
|
|
(define (row->concept-map-version row)
|
|
(hash 'version (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'document (text->document (vector-ref row 2))
|
|
'author (vector-ref row 3)
|
|
'action (vector-ref row 4)
|
|
'summary (vector-ref row 5)
|
|
'createdAt (vector-ref row 6)))
|
|
|
|
;;; Validates the address, title, shape, JSON encoding, and size of editor input.
|
|
(define (validate-concept-map-input who slug title document)
|
|
(unless (valid-slug? slug)
|
|
(error who "invalid concept map address: ~a" slug))
|
|
(when (string=? (string-trim title) "")
|
|
(error who "title is required"))
|
|
(unless (hash? document)
|
|
(raise-argument-error who "hash?" document))
|
|
(document->text document)
|
|
(void))
|
|
|
|
;;; Converts a number or numeric string to a version number, otherwise #f.
|
|
(define (version-number value)
|
|
(if (number? value) value (string->number (format "~a" value))))
|
|
|
|
;;; Inserts one immutable user-visible version within the current transaction.
|
|
(define (insert-concept-map-version! db map-id version title document-text
|
|
author action summary now)
|
|
(query-exec db
|
|
#<<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, $6, $7, $8)
|
|
SQL
|
|
map-id version title document-text author action summary now))
|
|
|
|
;;; Retains only the five newest manual versions while leaving snapshots intact.
|
|
(define (prune-manual-concept-map-versions! db map-id)
|
|
(query-exec
|
|
db
|
|
#<<SQL
|
|
DELETE FROM concept_map_versions
|
|
WHERE concept_map_id = $1
|
|
AND action = 'manual'
|
|
AND version NOT IN (
|
|
SELECT version
|
|
FROM concept_map_versions
|
|
WHERE concept_map_id = $1 AND action = 'manual'
|
|
ORDER BY version DESC
|
|
LIMIT 5
|
|
)
|
|
SQL
|
|
map-id))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List current concept-map metadata.
|
|
; pre : Database schema migration 9 has been installed.
|
|
; post : No database state is changed.
|
|
; result : A title-sorted list without the potentially large documents.
|
|
; internals: Selects active rows using concept-map-columns and maps each row
|
|
; through row->concept-map with document conversion disabled.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-concept-maps config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(map (λ (row) (row->concept-map row #f))
|
|
(query-rows
|
|
db
|
|
(string-append
|
|
"SELECT " concept-map-columns
|
|
" FROM concept_maps WHERE archived = FALSE"
|
|
" ORDER BY lower(title), title"))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
; internals: Selects archived rows with their audit columns and converts them
|
|
; through row->archived-concept-map, including SQL NULL handling.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-archived-concept-maps config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(map row->archived-concept-map
|
|
(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
|
|
)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Count current concept placements across every active CMap.
|
|
; pre : Concept-map documents use an items array when placements exist.
|
|
; post : No database state is changed.
|
|
; result : Rows containing global concept identity, linked page, concept/map
|
|
; labels, CMap slug and placement count.
|
|
; internals: PostgreSQL expands each active map's items array, joins shared
|
|
; concept_definitions, groups placements and row->concept-usage
|
|
; converts the grouped rows.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-concept-usage config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(map row->concept-usage
|
|
(query-rows
|
|
db
|
|
#<<SQL
|
|
WITH placements AS (
|
|
SELECT cm.slug,
|
|
cm.title AS cmap_title,
|
|
item ->> 'conceptId' AS concept_id,
|
|
coalesce(nullif(definition.document ->> 'label', ''),
|
|
nullif(repository.document ->> 'label', ''),
|
|
nullif(item ->> 'label', ''),
|
|
'Concept') AS concept_label,
|
|
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(
|
|
CASE
|
|
WHEN jsonb_typeof(cm.document -> 'items') = 'array'
|
|
THEN cm.document -> 'items'
|
|
ELSE '[]'::jsonb
|
|
END
|
|
) AS item
|
|
LEFT JOIN LATERAL (
|
|
SELECT concept_value AS document
|
|
FROM jsonb_array_elements(
|
|
CASE
|
|
WHEN jsonb_typeof(cm.document -> 'concepts') = 'array'
|
|
THEN cm.document -> 'concepts'
|
|
ELSE '[]'::jsonb
|
|
END
|
|
) AS concept_entry(concept_value)
|
|
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') <> 'phrase'
|
|
)
|
|
SELECT concept_id, slug, cmap_title, concept_label, page_slug, count(*)
|
|
FROM placements
|
|
GROUP BY concept_id, slug, cmap_title, concept_label, page_slug
|
|
ORDER BY concept_id, lower(cmap_title), cmap_title
|
|
SQL
|
|
)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
; internals: PostgreSQL selects definitions whose aspects contain TODO and a
|
|
; lateral join chooses one active placement; row->concept-todo
|
|
; converts nullable links to JSON null.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-concept-todos config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(map row->concept-todo
|
|
(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
|
|
)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List recently edited current concept maps.
|
|
; pre : Database schema migration 9 has been installed.
|
|
; post : Concept-map rows have only been read.
|
|
; result : At most limit metadata hashes, newest first.
|
|
; internals: Orders active concept_maps by updated_at, applies the SQL limit
|
|
; and maps the resulting rows without loading their documents.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-recent-concept-maps config [limit 50])
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(map (λ (row) (row->concept-map row #f))
|
|
(query-rows
|
|
db
|
|
(string-append
|
|
"SELECT " concept-map-columns
|
|
" FROM concept_maps WHERE archived = FALSE"
|
|
" ORDER BY updated_at DESC, lower(title), title"
|
|
" LIMIT $1")
|
|
limit)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Search current concept maps by map title, address and concept text.
|
|
; pre : query-text is a string and database schema 9 is installed.
|
|
; post : Concept-map documents have only been read.
|
|
; result : Up to 50 relevance-sorted search result hashes without documents.
|
|
; internals: PostgreSQL builds weighted full-text vectors from map identity and
|
|
; canonical concept text; row->search-result returns the ranked
|
|
; headline and metadata used by combined wiki search.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (search-concept-maps config query-text)
|
|
(if (string=? (string-trim query-text) "")
|
|
'()
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(map row->search-result
|
|
(query-rows
|
|
db
|
|
#<<SQL
|
|
WITH q AS (
|
|
SELECT websearch_to_tsquery('simple', $1) AS query
|
|
), map_documents AS (
|
|
SELECT cm.slug,
|
|
cm.title,
|
|
coalesce((
|
|
SELECT string_agg(
|
|
concat_ws(' ', coalesce(definition.document, concept) ->> 'label',
|
|
coalesce(definition.document, concept) ->> 'synopsis'),
|
|
' ')
|
|
FROM jsonb_array_elements(
|
|
CASE
|
|
WHEN jsonb_typeof(cm.document -> 'concepts') = 'array'
|
|
THEN cm.document -> 'concepts'
|
|
ELSE '[]'::jsonb
|
|
END) AS concept
|
|
LEFT JOIN concept_definitions definition
|
|
ON definition.id = concept ->> 'id'
|
|
), '') AS concept_text
|
|
FROM concept_maps cm
|
|
WHERE cm.archived = FALSE
|
|
), ranked AS (
|
|
SELECT slug,
|
|
title,
|
|
concept_text,
|
|
setweight(to_tsvector('simple', coalesce(title, '') || ' ' || coalesce(slug, '')), 'A') ||
|
|
setweight(to_tsvector('simple', concept_text), 'B') AS search_document
|
|
FROM map_documents
|
|
)
|
|
SELECT ranked.slug,
|
|
ranked.title,
|
|
ts_rank(ranked.search_document, q.query) AS rank,
|
|
ts_headline(
|
|
'simple',
|
|
concat_ws(' ', ranked.title, ranked.concept_text),
|
|
q.query,
|
|
'StartSel=[[[, StopSel=]]], MaxWords=28, MinWords=8, ShortWord=2') AS snippet
|
|
FROM ranked, q
|
|
WHERE ranked.search_document @@ q.query
|
|
ORDER BY rank DESC, lower(ranked.title), ranked.title
|
|
LIMIT 50
|
|
SQL
|
|
query-text))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Read one current concept map including its editor document.
|
|
; pre : slug is a string.
|
|
; post : No database state is changed.
|
|
; result : Concept-map hash, or #f when no current map has that slug.
|
|
; internals: Reads the active concept_maps row, row->concept-map decodes its
|
|
; document and hydrate-concept-definitions replaces references with
|
|
; the canonical shared concept content required by the editor.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (read-concept-map config slug)
|
|
(if (not (valid-slug? slug))
|
|
#f
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(let ((row
|
|
(query-maybe-row
|
|
db
|
|
(string-append
|
|
"SELECT " concept-map-columns
|
|
" FROM concept_maps WHERE slug = $1 AND archived = FALSE")
|
|
slug)))
|
|
(if row
|
|
(hash-update (row->concept-map row)
|
|
'document
|
|
(λ (document) (hydrate-concept-definitions db document)))
|
|
#f))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a persistent concept map.
|
|
; pre : slug is unused, title is non-empty and document is a JSON object.
|
|
; post : One concept_maps row exists at version 1; history starts only when
|
|
; the user explicitly saves or creates a snapshot.
|
|
; result : The newly stored concept-map hash.
|
|
; internals: Inside one transaction, canonicalize-document-concepts resolves
|
|
; shared UUIDs, sync-concept-definitions! and sync-person-tags!
|
|
; update shared registries, and concept-map-storage-document strips
|
|
; duplicate content before insertion. read-concept-map hydrates the result.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (create-concept-map! config slug title document author)
|
|
(let* ((clean-slug (string-trim slug))
|
|
(clean-title (string-trim title))
|
|
(now (current-seconds)))
|
|
(validate-concept-map-input 'create-concept-map! clean-slug clean-title document)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(let* ((canonical-document
|
|
(canonicalize-document-concepts db document))
|
|
(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
|
|
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
|
|
clean-slug clean-title document-text now author))))))
|
|
(read-concept-map config clean-slug)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Rename a concept map without storing unsaved editor content.
|
|
; pre : slug identifies a current map and base-version is current.
|
|
; post : Title, version and audit fields are updated atomically without
|
|
; adding a user-facing history item.
|
|
; result : The renamed concept-map hash with its unchanged document.
|
|
; internals: Locks the active concept_maps row, compares version-number with
|
|
; current_version, increments the version and audit fields, then
|
|
; uses read-concept-map to return the unchanged hydrated document.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (rename-concept-map! config slug title author base-version)
|
|
(let ((clean-title (string-trim title)))
|
|
(when (string=? clean-title "")
|
|
(error 'rename-concept-map! "title is required"))
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(let ((row
|
|
(query-maybe-row
|
|
db
|
|
#<<SQL
|
|
SELECT id, current_version, document::text
|
|
FROM concept_maps
|
|
WHERE slug = $1 AND archived = FALSE
|
|
FOR UPDATE
|
|
SQL
|
|
slug)))
|
|
(unless row
|
|
(error 'rename-concept-map! "unknown concept map: ~a" slug))
|
|
(let* ((current-version (vector-ref row 1))
|
|
(supplied-version (version-number base-version)))
|
|
(unless (and supplied-version (= supplied-version current-version))
|
|
(error 'rename-concept-map! "version-conflict"))
|
|
(let ((next-version (+ current-version 1))
|
|
(now (current-seconds)))
|
|
(query-exec
|
|
db
|
|
#<<SQL
|
|
UPDATE concept_maps
|
|
SET title = $1,
|
|
current_version = $2,
|
|
updated_at = $3,
|
|
updated_by = $4
|
|
WHERE id = $5
|
|
SQL
|
|
clean-title
|
|
next-version
|
|
now
|
|
author
|
|
(vector-ref row 0))
|
|
(void))))))))
|
|
(read-concept-map config slug)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Store the current state of an existing concept map.
|
|
; pre : base-version equals the current database version.
|
|
; post : Current state and version are updated atomically. Autosaves create
|
|
; no history row; snapshots are unlimited; only five manual saves remain.
|
|
; result : The updated concept-map hash.
|
|
; internals: Locks and version-checks the active row, canonicalizes concepts,
|
|
; synchronizes shared definitions and people, stores the reduced
|
|
; document, and writes history according to action. Manual history
|
|
; is pruned by prune-manual-concept-map-versions! before read-back.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (update-concept-map! config slug title document author base-version
|
|
[summary "Edited CMap"] [action "manual"])
|
|
(unless (member action '("autosave" "manual" "snapshot"))
|
|
(error 'update-concept-map! "invalid save action: ~a" action))
|
|
(let ((clean-title (string-trim title)))
|
|
(validate-concept-map-input 'update-concept-map! slug clean-title document)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(let ((row
|
|
(query-maybe-row
|
|
db
|
|
#<<SQL
|
|
SELECT id, current_version
|
|
FROM concept_maps
|
|
WHERE slug = $1 AND archived = FALSE
|
|
FOR UPDATE
|
|
SQL
|
|
slug)))
|
|
(unless row
|
|
(error 'update-concept-map! "unknown concept map: ~a" slug))
|
|
(let* ((current-version (vector-ref row 1))
|
|
(supplied-version (version-number base-version)))
|
|
(unless (and supplied-version (= supplied-version current-version))
|
|
(error 'update-concept-map! "version-conflict"))
|
|
(let* ((next-version (+ current-version 1))
|
|
(now (current-seconds))
|
|
(canonical-document
|
|
(canonicalize-document-concepts db document))
|
|
(document-text
|
|
(document->text
|
|
(concept-map-storage-document canonical-document))))
|
|
(sync-concept-definitions! db canonical-document author now)
|
|
(query-exec
|
|
db
|
|
#<<SQL
|
|
UPDATE concept_maps
|
|
SET title = $1,
|
|
document = $2::text::jsonb,
|
|
current_version = $3,
|
|
updated_at = $4,
|
|
updated_by = $5
|
|
WHERE id = $6
|
|
SQL
|
|
clean-title
|
|
document-text
|
|
next-version
|
|
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
|
|
author action summary now))
|
|
(when (string=? action "manual")
|
|
(prune-manual-concept-map-versions!
|
|
db (vector-ref row 0))))))))))
|
|
(read-concept-map config slug)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Read immutable version metadata for a concept map.
|
|
; pre : slug identifies a current concept map.
|
|
; post : Version rows have only been read.
|
|
; result : A newest-first list without the potentially large documents.
|
|
; internals: Resolves the active map id, selects snapshot and manual rows only,
|
|
; and maps them through row->history-entry without decoding documents.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (concept-map-history config slug)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(let ((map-id
|
|
(query-maybe-value
|
|
db
|
|
"SELECT id FROM concept_maps WHERE slug = $1 AND archived = FALSE"
|
|
slug)))
|
|
(unless map-id
|
|
(error 'concept-map-history "unknown concept map: ~a" slug))
|
|
(map row->history-entry
|
|
(query-rows db
|
|
#<<SQL
|
|
SELECT version, title, author, action, summary, created_at
|
|
FROM concept_map_versions
|
|
WHERE concept_map_id = $1 AND action IN ('snapshot', 'manual')
|
|
ORDER BY version DESC
|
|
SQL
|
|
map-id))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Read one immutable concept-map version.
|
|
; pre : slug and version identify a possible historical version.
|
|
; post : Version rows have only been read.
|
|
; result : Version metadata including its editor document, or #f.
|
|
; internals: version-number validates the requested value; a joined query keeps
|
|
; archived maps inaccessible and row->concept-map-version decodes
|
|
; the selected immutable document.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (read-concept-map-version config slug version)
|
|
(let ((requested-version (version-number version)))
|
|
(if requested-version
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(let ((row
|
|
(query-maybe-row db
|
|
#<<SQL
|
|
SELECT cmv.version, cmv.title, cmv.document::text, cmv.author,
|
|
cmv.action, cmv.summary, cmv.created_at
|
|
FROM concept_map_versions cmv
|
|
JOIN concept_maps cm ON cm.id = cmv.concept_map_id
|
|
WHERE cm.slug = $1 AND cm.archived = FALSE AND cmv.version = $2
|
|
SQL
|
|
slug requested-version)))
|
|
(if row (row->concept-map-version row) #f))))
|
|
#f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Delete one user-facing concept-map history item.
|
|
; pre : slug identifies a current map and version is numeric.
|
|
; post : Only the selected snapshot or manual-save row is removed; the
|
|
; current concept_maps document and version are unchanged.
|
|
; result : #t when an item was deleted, #f when it did not exist.
|
|
; internals: version-number validates the request and one joined DELETE limits
|
|
; removal to user-visible history belonging to an active map.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (delete-concept-map-version! config slug version)
|
|
(let ((requested-version (version-number version)))
|
|
(if requested-version
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(if (query-maybe-value
|
|
db
|
|
#<<SQL
|
|
DELETE FROM concept_map_versions cmv
|
|
USING concept_maps cm
|
|
WHERE cm.id = cmv.concept_map_id
|
|
AND cm.slug = $1
|
|
AND cm.archived = FALSE
|
|
AND cmv.version = $2
|
|
AND cmv.action IN ('snapshot', 'manual')
|
|
RETURNING cmv.version
|
|
SQL
|
|
slug requested-version)
|
|
#t
|
|
#f)))
|
|
#f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
; internals: Locks the active row, verifies the exact title and current version,
|
|
; then sets archive and audit columns in the same transaction.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (archive-concept-map! config slug expected-title author base-version)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(let ((row
|
|
(query-maybe-row
|
|
db
|
|
#<<SQL
|
|
SELECT id, title, current_version
|
|
FROM concept_maps
|
|
WHERE slug = $1 AND archived = FALSE
|
|
FOR UPDATE
|
|
SQL
|
|
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"))
|
|
(let ((supplied-version (version-number base-version)))
|
|
(unless (and supplied-version (= supplied-version (vector-ref row 2)))
|
|
(error 'archive-concept-map! "version-conflict"))
|
|
(let ((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 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.
|
|
; internals: UPDATE clears the archive audit columns and returns the restored id;
|
|
; read-concept-map then returns the normal hydrated representation.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (restore-concept-map! config slug author)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(let ((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)))
|
|
(unless restored-id
|
|
(error 'restore-concept-map! "unknown archived concept map: ~a" slug)))))
|
|
(read-concept-map config slug))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Tests for module cmap-storage.rkt.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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? (version-number 7) 7)
|
|
(check-equal? (version-number "7") 7)
|
|
(check-false (version-number "invalid"))
|
|
(check-equal?
|
|
(hash-ref (text->document (jsexpr->string (jsexpr->string (hash 'value 7))))
|
|
'value)
|
|
7)
|
|
(check-equal? (document-items (hash 'items "invalid")) '())
|
|
(check-equal? (hash-ref (concept-content
|
|
(hash 'id concept-a
|
|
'label "Linked concept"
|
|
'externalUrl "https://example.com/path"))
|
|
'externalUrl)
|
|
"https://example.com/path")
|
|
(check-equal?
|
|
(hash-ref
|
|
(concept-content
|
|
(hash 'id concept-a
|
|
'tags (list (hash 'type "person" 'value "Alex")
|
|
(hash 'type "label" 'value "Architecture"))))
|
|
'tags)
|
|
(list (hash 'type "person" 'value "Alex")))
|
|
(check-exn exn:fail?
|
|
(λ ()
|
|
(concept-content
|
|
(hash 'id concept-a
|
|
'label "Unsafe concept"
|
|
'externalUrl "javascript:alert(1)"))))
|
|
(check-exn exn:fail?
|
|
(λ ()
|
|
(concept-map-storage-document
|
|
(hash 'concepts (list (hash 'id "legacy:map:concept-1"))
|
|
'items '())))))
|