Bettern cmap handling. Lots of changes.
This commit is contained in:
@@ -0,0 +1,338 @@
|
||||
#lang racket/base
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PostgreSQL-backed concept-map storage.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require db
|
||||
json
|
||||
racket/string
|
||||
"database.rkt"
|
||||
"storage.rkt")
|
||||
|
||||
(provide list-concept-maps
|
||||
list-recent-concept-maps
|
||||
search-concept-maps
|
||||
read-concept-map
|
||||
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))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; 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 : 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.
|
||||
; 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)
|
||||
(query-exec
|
||||
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)
|
||||
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.
|
||||
; 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 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"))
|
||||
(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
|
||||
(+ current-version 1)
|
||||
(current-seconds)
|
||||
author
|
||||
(vector-ref row 0))))))
|
||||
(read-concept-map config slug))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store a new version of an existing concept map.
|
||||
; pre : base-version equals the current database version.
|
||||
; post : Title, document, version and audit fields are updated atomically.
|
||||
; result : The updated concept-map hash.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (update-concept-map! config slug title document author base-version)
|
||||
(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"))
|
||||
(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
|
||||
(+ current-version 1)
|
||||
(current-seconds)
|
||||
author
|
||||
(vector-ref row 0))))))
|
||||
(read-concept-map config slug))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; 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))
|
||||
Reference in New Issue
Block a user