552 lines
20 KiB
Racket
552 lines
20 KiB
Racket
#lang racket/base
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PostgreSQL-backed concept-map storage.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require db
|
|
json
|
|
racket/string
|
|
"database.rkt"
|
|
"storage.rkt")
|
|
|
|
(provide list-concept-maps
|
|
list-concept-usage
|
|
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!)
|
|
|
|
(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")
|
|
|
|
(define (document->text document)
|
|
(unless (jsexpr? document)
|
|
(raise-argument-error 'document->text "jsexpr?" document))
|
|
(define 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)
|
|
|
|
(define (text->document text)
|
|
(with-handlers ((exn:fail?
|
|
(λ (e)
|
|
(error 'text->document
|
|
"invalid stored concept map document: ~a"
|
|
(exn-message e)))))
|
|
(define parsed (string->jsexpr text))
|
|
(define document
|
|
(if (string? parsed)
|
|
(string->jsexpr parsed)
|
|
parsed))
|
|
(unless (hash? document)
|
|
(error 'text->document "stored concept map document is not a JSON object"))
|
|
document))
|
|
|
|
(define (row->concept-map row [include-document? #t])
|
|
(define 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))
|
|
|
|
(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))
|
|
|
|
(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))
|
|
|
|
(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))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-concept-maps config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/list ((row (in-list
|
|
(query-rows
|
|
db
|
|
(string-append
|
|
"SELECT " concept-map-columns
|
|
" FROM concept_maps WHERE archived = FALSE"
|
|
" ORDER BY lower(title), title")))))
|
|
(row->concept-map row #f)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-concept-usage config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/list ((row (in-list
|
|
(query-rows
|
|
db
|
|
#<<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', ''),
|
|
nullif(item ->> 'label', ''),
|
|
'Concept') AS concept_label,
|
|
coalesce(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
|
|
WHERE cm.archived = FALSE
|
|
AND nullif(item ->> 'conceptId', '') IS NOT NULL
|
|
AND coalesce(item ->> 'kind', 'concept') NOT IN ('phrase', 'submap')
|
|
)
|
|
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
|
|
))))
|
|
(hash 'conceptId (vector-ref row 0)
|
|
'cmapSlug (vector-ref row 1)
|
|
'cmapTitle (vector-ref row 2)
|
|
'label (vector-ref row 3)
|
|
'pageSlug (if (sql-null? (vector-ref row 4))
|
|
'null
|
|
(vector-ref row 4))
|
|
'count (vector-ref row 5))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-recent-concept-maps config [limit 50])
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/list ((row (in-list
|
|
(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))))
|
|
(row->concept-map row #f)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (search-concept-maps config query-text)
|
|
(if (string=? (string-trim query-text) "")
|
|
'()
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/list ((row (in-list
|
|
(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(' ', item ->> 'label', item ->> 'synopsis'),
|
|
' ')
|
|
FROM jsonb_array_elements(
|
|
CASE
|
|
WHEN jsonb_typeof(cm.document -> 'items') = 'array'
|
|
THEN cm.document -> 'items'
|
|
ELSE '[]'::jsonb
|
|
END) AS item
|
|
), '') 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))))
|
|
(hash 'slug (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'rank (vector-ref row 2)
|
|
'snippet (vector-ref row 3)
|
|
'type "cmap"))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (read-concept-map config slug)
|
|
(if (not (valid-slug? slug))
|
|
#f
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define row
|
|
(query-maybe-row
|
|
db
|
|
(string-append
|
|
"SELECT " concept-map-columns
|
|
" FROM concept_maps WHERE slug = $1 AND archived = FALSE")
|
|
slug))
|
|
(if row (row->concept-map row) #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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (create-concept-map! config slug title document author)
|
|
(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
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (rename-concept-map! config slug title author base-version)
|
|
(define 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
|
|
(λ ()
|
|
(define row
|
|
(query-maybe-row
|
|
db
|
|
"SELECT id, current_version, document::text FROM concept_maps WHERE slug = $1 AND archived = FALSE FOR UPDATE"
|
|
slug))
|
|
(unless row
|
|
(error 'rename-concept-map! "unknown concept map: ~a" slug))
|
|
(define current-version (vector-ref row 1))
|
|
(define supplied-version
|
|
(if (number? base-version)
|
|
base-version
|
|
(string->number (format "~a" base-version))))
|
|
(unless (and supplied-version (= supplied-version current-version))
|
|
(error 'rename-concept-map! "version-conflict"))
|
|
(define next-version (+ current-version 1))
|
|
(define 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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))
|
|
(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)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(define row
|
|
(query-maybe-row
|
|
db
|
|
"SELECT id, current_version FROM concept_maps WHERE slug = $1 AND archived = FALSE FOR UPDATE"
|
|
slug))
|
|
(unless row
|
|
(error 'update-concept-map! "unknown concept map: ~a" slug))
|
|
(define current-version (vector-ref row 1))
|
|
(define supplied-version
|
|
(if (number? base-version)
|
|
base-version
|
|
(string->number (format "~a" base-version))))
|
|
(unless (and supplied-version (= supplied-version current-version))
|
|
(error 'update-concept-map! "version-conflict"))
|
|
(define next-version (+ current-version 1))
|
|
(define now (current-seconds))
|
|
(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))
|
|
(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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (concept-map-history config slug)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define 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))
|
|
(for/list ((row (in-list
|
|
(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))))
|
|
(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))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (read-concept-map-version config slug version)
|
|
(define version-number
|
|
(if (number? version) version (string->number version)))
|
|
(and version-number
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define 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 version-number))
|
|
(and 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)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (delete-concept-map-version! config slug version)
|
|
(define version-number
|
|
(if (number? version) version (string->number version)))
|
|
(and version-number
|
|
(call-with-wiki-database
|
|
config
|
|
(lambda (db)
|
|
(and
|
|
(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 version-number)
|
|
#t)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Soft-delete one concept map.
|
|
; pre : slug identifies a current map.
|
|
; post : The map is excluded from normal list/read operations.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (archive-concept-map! config slug author)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define changed
|
|
(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
|
|
SQL
|
|
(current-seconds) author slug))
|
|
(void changed)))
|
|
(void))
|