Bettern cmap handling. Lots of changes.

private/attachment-references.rkt

@@ -18,28 +18,48 @@
 (define (attachment-rows db)
   (query-rows db
               #<<SQL
-SELECT a.id, p.slug, a.stored_name, p.namespace
+SELECT a.id, a.page_id, a.stored_name
 FROM attachments a
-JOIN pages p ON p.id = a.page_id
 ORDER BY a.id
 SQL
               ))
 
-(define (attachment-url slug stored-name)
-  (format "/uploads/~a/~a" slug stored-name))
+(define (attachment-url reference stored-name)
+  (format "/uploads/~a/~a" reference stored-name))
+
+(define (page-references db page-id)
+  (define current
+    (query-row db
+               "SELECT namespace, slug FROM pages WHERE id = $1"
+               page-id))
+  (define references
+    (list (if (string=? (vector-ref current 0) "")
+              (vector-ref current 1)
+              (string-append (vector-ref current 0) ":" (vector-ref current 1)))))
+  (define aliases-available?
+    (query-value db "SELECT to_regclass('page_aliases') IS NOT NULL"))
+  (when aliases-available?
+    (for ((row (in-list
+                (query-rows db
+                            "SELECT namespace, slug FROM page_aliases WHERE page_id = $1 ORDER BY id"
+                            page-id))))
+      (define reference
+        (if (string=? (vector-ref row 0) "")
+            (vector-ref row 1)
+            (string-append (vector-ref row 0) ":" (vector-ref row 1))))
+      (set! references (cons reference references))))
+  references)
 
 (define (record-references! db page-id page-version-id markdown current? referenced-at)
   (for ((row (in-list (attachment-rows db))))
     (define attachment-id (vector-ref row 0))
-    (define slug (vector-ref row 1))
+    (define owner-page-id (vector-ref row 1))
     (define stored-name (vector-ref row 2))
-    (define namespace (vector-ref row 3))
-    (define reference (if (string=? namespace "") slug (string-append namespace ":" slug)))
-    (define current-url (attachment-url reference stored-name))
-    (define legacy-url (attachment-url slug stored-name))
-    (when (or (string-contains? markdown current-url)
-              (and (not (string=? namespace ""))
-                   (string-contains? markdown legacy-url)))
+    (define found? #f)
+    (for ((reference (in-list (page-references db owner-page-id))))
+      (when (string-contains? markdown (attachment-url reference stored-name))
+        (set! found? #t)))
+    (when found?
       (query-exec db
                   #<<SQL
 INSERT INTO attachment_references

private/cmap-storage.rkt

@@ -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))

private/database.rkt

@@ -131,4 +131,5 @@
             (and (query-value db "SELECT to_regclass('public.users') IS NOT NULL")
                  (query-value db "SELECT to_regclass('public.pages') IS NOT NULL")
                  (query-value db "SELECT to_regclass('public.page_versions') IS NOT NULL")
+                 (query-value db "SELECT to_regclass('public.concept_maps') IS NOT NULL")
                  (query-value db "SELECT to_regclass('public.sessions') IS NOT NULL")))))))

private/migrations.rkt

@@ -20,7 +20,7 @@
 ;; Supporting functions
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define current-schema-version 7)
+(define current-schema-version 9)
 
 (define schema-1-statements
   (list
@@ -281,6 +281,48 @@ SQL
   (query-exec db "CREATE INDEX IF NOT EXISTS pages_namespace_idx ON pages(lower(namespace), lower(title), title)")
   (record-schema-version! db 7))
 
+(define (migrate-7->8! db)
+  (query-exec db
+              #<<SQL
+CREATE TABLE IF NOT EXISTS page_aliases (
+  id BIGSERIAL PRIMARY KEY,
+  namespace TEXT NOT NULL DEFAULT '',
+  slug TEXT NOT NULL,
+  title TEXT NOT NULL,
+  page_id BIGINT NOT NULL REFERENCES pages(id) ON DELETE CASCADE,
+  created_at BIGINT NOT NULL,
+  created_by TEXT NOT NULL,
+  UNIQUE(namespace, slug)
+)
+SQL
+              )
+  (query-exec db
+              "CREATE INDEX IF NOT EXISTS page_aliases_page_idx ON page_aliases(page_id, created_at DESC)")
+  (record-schema-version! db 8))
+
+(define (migrate-8->9! db)
+  (query-exec db
+              #<<SQL
+CREATE TABLE IF NOT EXISTS concept_maps (
+  id BIGSERIAL PRIMARY KEY,
+  slug TEXT NOT NULL UNIQUE,
+  title TEXT NOT NULL,
+  document JSONB NOT NULL,
+  current_version BIGINT NOT NULL DEFAULT 1,
+  created_at BIGINT NOT NULL,
+  updated_at BIGINT NOT NULL,
+  created_by TEXT NOT NULL,
+  updated_by TEXT NOT NULL,
+  archived BOOLEAN NOT NULL DEFAULT FALSE,
+  archived_at BIGINT,
+  archived_by TEXT
+)
+SQL
+              )
+  (query-exec db
+              "CREATE INDEX IF NOT EXISTS concept_maps_title_idx ON concept_maps(lower(title))")
+  (record-schema-version! db 9))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Bring a racket-wiki PostgreSQL database to the current schema.
 ; pre    : db is a writable PostgreSQL connection and config identifies the
@@ -313,6 +355,12 @@ SQL
      (define after-attachment-references (database-schema-version db))
      (when (= after-attachment-references 6)
        (migrate-6->7! db))
+     (define after-namespaces (database-schema-version db))
+     (when (= after-namespaces 7)
+       (migrate-7->8! db))
+     (define after-page-aliases (database-schema-version db))
+     (when (= after-page-aliases 8)
+       (migrate-8->9! db))
      (define resulting-version (database-schema-version db))
      (when (> resulting-version current-schema-version)
        (error 'migrate-database!

private/storage.rkt

@@ -25,6 +25,7 @@
          read-page
          create-page!
          update-page!
+         rename-page!
          archive-page!
          page-history
          read-version
@@ -36,6 +37,10 @@
          delete-bookmark!
          list-orphaned-uploads
          delete-orphaned-upload!
+         list-page-aliases
+         list-page-alias-details
+         cleanup-page-alias!
+         delete-page-alias!
          save-upload!
          uploaded-file)
 
@@ -168,6 +173,25 @@
 (define page-columns
   "slug, title, markdown, created_at, updated_at, created_by, updated_by, tags, current_version, namespace")
 
+(define page-columns/prefixed
+  "p.slug, p.title, p.markdown, p.created_at, p.updated_at, p.created_by, p.updated_by, p.tags, p.current_version, p.namespace")
+
+(define (page-id/db db namespace slug)
+  (define current-id
+    (query-maybe-value db
+                       "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
+                       namespace slug))
+  (if current-id
+      current-id
+      (query-maybe-value db
+                         #<<SQL
+SELECT p.id
+FROM page_aliases a
+JOIN pages p ON p.id = a.page_id
+WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE
+SQL
+                         namespace slug)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : List current wiki page metadata.
 ; pre    : The PostgreSQL schema is initialized.
@@ -202,8 +226,16 @@
                               (string-append "SELECT " page-columns
                                              " FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE")
                               namespace slug))
-           (if row (row->page row) #f))))))
-
+           (define resolved-row
+             (if row
+                 row
+                 (query-maybe-row db
+                                  (string-append
+                                   "SELECT " page-columns/prefixed
+                                   " FROM page_aliases a JOIN pages p ON p.id = a.page_id"
+                                   " WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE")
+                                  namespace slug)))
+           (if resolved-row (row->page resolved-row) #f))))))
 
 (define (replace-todos! db page-id markdown)
   (query-exec db "DELETE FROM todo_items WHERE page_id = $1" page-id)
@@ -286,14 +318,10 @@ SQL
           (error 'update-page! "version-conflict"))
         (define page-tags
           (if tags tags (text->tags (vector-ref row 2))))
-        (define target-namespace
-          (if (eq? new-namespace #f)
-              (vector-ref row 3)
-              (string-trim new-namespace)))
-        (unless (or (string=? target-namespace "")
-                    (and (valid-slug? target-namespace)
-                         (<= (string-length target-namespace) 80)))
-          (error 'update-page! "invalid namespace: ~a" target-namespace))
+        (define target-namespace (vector-ref row 3))
+        (when (and (not (eq? new-namespace #f))
+                   (not (string=? (string-trim new-namespace) target-namespace)))
+          (error 'update-page! "use rename-page! to change a page namespace"))
         (define next-version (+ current-version 1))
         (define now (current-seconds))
         (query-exec db
@@ -312,7 +340,85 @@ SQL
         (replace-todos! db page-id markdown)
         (replace-current-attachment-references! db page-id markdown now)
         (record-version-attachment-references! db page-id page-version-id markdown now)))))
-  (read-page config (page-reference (if (eq? new-namespace #f) namespace (string-trim new-namespace)) slug)))
+  (read-page config (page-reference namespace slug)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Rename or move a page while keeping its old address as an alias.
+; pre    : reference identifies a current page; target namespace/slug are valid and unused.
+; post   : The same page_id has the new address/title, the old address remains an alias,
+;          and a new immutable page version records the rename.
+; result : The renamed page metadata with Markdown.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (rename-page! config reference title target-namespace target-slug author [summary "Renamed page"])
+  (define-values (namespace slug) (split-page-reference reference))
+  (define clean-namespace (string-trim target-namespace))
+  (define clean-slug (string-trim target-slug))
+  (unless (valid-page-reference? (page-reference clean-namespace clean-slug))
+    (error 'rename-page! "invalid page address: ~a" (page-reference clean-namespace clean-slug)))
+  (when (string=? (string-trim title) "")
+    (error 'rename-page! "title is required"))
+  (call-with-wiki-database
+   config
+   (λ (db)
+     (call-with-transaction
+      db
+      (λ ()
+        (define row
+          (query-maybe-row db
+                           "SELECT id, title, markdown, tags, current_version FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
+                           namespace slug))
+        (unless row
+          (error 'rename-page! "unknown page: ~a" reference))
+        (define page-id (vector-ref row 0))
+        (define old-title (vector-ref row 1))
+        (define markdown (vector-ref row 2))
+        (define tags (text->tags (vector-ref row 3)))
+        (define current-version (vector-ref row 4))
+        (define address-changed?
+          (or (not (string=? namespace clean-namespace))
+              (not (string=? slug clean-slug))))
+        (when address-changed?
+          (define target-page-id
+            (query-maybe-value db
+                               "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
+                               clean-namespace clean-slug))
+          (when (and target-page-id (not (= target-page-id page-id)))
+            (error 'rename-page! "page address is already in use: ~a"
+                   (page-reference clean-namespace clean-slug)))
+          (define target-alias-page-id
+            (query-maybe-value db
+                               "SELECT page_id FROM page_aliases WHERE namespace = $1 AND slug = $2"
+                               clean-namespace clean-slug))
+          (when (and target-alias-page-id (not (= target-alias-page-id page-id)))
+            (error 'rename-page! "page address is already an alias: ~a"
+                   (page-reference clean-namespace clean-slug)))
+          (when target-alias-page-id
+            (query-exec db
+                        "DELETE FROM page_aliases WHERE namespace = $1 AND slug = $2 AND page_id = $3"
+                        clean-namespace clean-slug page-id))
+          (query-exec db
+                      #<<SQL
+INSERT INTO page_aliases(namespace, slug, title, page_id, created_at, created_by)
+VALUES ($1, $2, $3, $4, $5, $6)
+ON CONFLICT (namespace, slug) DO NOTHING
+SQL
+                      namespace slug old-title page-id (current-seconds) author))
+        (define next-version (+ current-version 1))
+        (define now (current-seconds))
+        (query-exec db
+                    #<<SQL
+UPDATE pages
+SET namespace = $1, slug = $2, title = $3, current_version = $4,
+    updated_at = $5, updated_by = $6,
+    search_document = setweight(to_tsvector('simple', coalesce($3, '')), 'A') ||
+                      setweight(to_tsvector('simple', coalesce(markdown, '')), 'B')
+WHERE id = $7
+SQL
+                    clean-namespace clean-slug title next-version now author page-id)
+        (define page-version-id
+          (insert-version! db page-id next-version title markdown author "rename" summary now tags))
+        (record-version-attachment-references! db page-id page-version-id markdown now)))))
+  (read-page config (page-reference clean-namespace clean-slug)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Archive an existing wiki page.
@@ -346,9 +452,7 @@ SQL
   (call-with-wiki-database
    config
    (λ (db)
-     (query-maybe-value db
-                        "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
-                        namespace slug))))
+     (page-id/db db namespace slug))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Read the version history for a wiki page.
@@ -361,8 +465,7 @@ SQL
   (call-with-wiki-database
    config
    (λ (db)
-     (define id
-       (query-maybe-value db "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE" namespace slug))
+     (define id (page-id/db db namespace slug))
      (unless id
        (error 'page-history "unknown page: ~a" slug))
      (for/list ((row (in-list
@@ -396,15 +499,16 @@ SQL
        (call-with-wiki-database
         config
         (λ (db)
+          (define id (page-id/db db namespace slug))
           (define row
-            (query-maybe-row db
-                             #<<SQL
-SELECT v.version, v.title, v.markdown, v.author, v.action, v.summary, v.tags, v.created_at
-FROM page_versions v
-JOIN pages p ON p.id = v.page_id
-WHERE p.namespace = $1 AND p.slug = $2 AND p.archived = FALSE AND v.version = $3
+            (and id
+                 (query-maybe-row db
+                                  #<<SQL
+SELECT version, title, markdown, author, action, summary, tags, created_at
+FROM page_versions
+WHERE page_id = $1 AND version = $2
 SQL
-                             namespace slug version-number))
+                                  id version-number)))
           (and row
                (hash 'version (vector-ref row 0)
                      'title (vector-ref row 1)
@@ -448,7 +552,8 @@ SQL
                  'namespace (vector-ref row 4)
                  'title (vector-ref row 1)
                  'rank (vector-ref row 2)
-                 'snippet (vector-ref row 3)))))))
+                 'snippet (vector-ref row 3)
+                 'type "page"))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : List unresolved todo(...) markers from all current wiki pages.
@@ -679,6 +784,307 @@ SQL
           (error 'delete-orphaned-upload! "unknown attachment: ~a" attachment-id))))))
   (void))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Page alias cleanup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (title->wiki-word title)
+  (define words '())
+  (define out (open-output-string))
+  (define (finish-word!)
+    (define word (get-output-string out))
+    (when (> (string-length word) 0)
+      (set! words (append words (list word))))
+    (set! out (open-output-string)))
+  (for ((char (in-string title)))
+    (if (char-alphabetic? char)
+        (write-char char out)
+        (finish-word!)))
+  (finish-word!)
+  (apply string-append
+         (for/list ((word (in-list words)))
+           (string-titlecase word))))
+
+(define (classic-wiki-word? text)
+  (regexp-match? #px"^(?:[A-Z][a-z]+){2,}$" text))
+
+(define (alias-wiki-reference namespace title)
+  (define wiki-word (title->wiki-word title))
+  (if (classic-wiki-word? wiki-word)
+      (if (string=? namespace "")
+          wiki-word
+          (string-append namespace ":" wiki-word))
+      #f))
+
+(define (replace-wiki-token line old-token new-text)
+  (define out (open-output-string))
+  (define length (string-length line))
+  (let loop ((index 0))
+    (when (< index length)
+      (define char (string-ref line index))
+      (if (or (char-alphabetic? char) (char=? char #\:))
+          (let find-end ((end index))
+            (if (and (< end length)
+                     (let ((candidate (string-ref line end)))
+                       (or (char-alphabetic? candidate) (char=? candidate #\:))))
+                (find-end (+ end 1))
+                (let ((token (substring line index end)))
+                  (display (if (string=? token old-token) new-text token) out)
+                  (loop end))))
+          (begin
+            (write-char char out)
+            (loop (+ index 1))))))
+  (get-output-string out))
+
+(define (replace-alias-reference-in-line line old-reference new-reference old-wiki new-wiki)
+  (define result line)
+  (set! result
+        (string-replace result
+                        (string-append "(" old-reference ")")
+                        (string-append "(" new-reference ")")))
+  (set! result
+        (string-replace result
+                        (string-append "(" old-reference " ")
+                        (string-append "(" new-reference " ")))
+  (set! result
+        (string-replace result
+                        (string-append "/uploads/" old-reference "/")
+                        (string-append "/uploads/" new-reference "/")))
+  (if old-wiki
+      (replace-wiki-token result old-wiki new-wiki)
+      result))
+
+(define (replace-alias-reference markdown old-namespace old-slug old-title
+                                 new-namespace new-slug new-title)
+  (define old-reference (page-reference old-namespace old-slug))
+  (define new-reference (page-reference new-namespace new-slug))
+  (define old-wiki (alias-wiki-reference old-namespace old-title))
+  (define target-wiki (alias-wiki-reference new-namespace new-title))
+  (define new-wiki
+    (if target-wiki
+        target-wiki
+        (format "[~a](~a)" new-title new-reference)))
+  (define in-fence? #f)
+  (define result
+    (for/list ((line (in-list (string-split markdown "\n" #:trim? #f))))
+      (define fence? (regexp-match? #px"^[ \t]*(```|~~~)" line))
+      (cond
+        (fence?
+         (set! in-fence? (not in-fence?))
+         line)
+        ((or in-fence?
+             (string-prefix? line "    ")
+             (string-prefix? line "\t")
+             (string-contains? line "`"))
+         line)
+        (else
+         (replace-alias-reference-in-line line old-reference new-reference old-wiki new-wiki)))))
+  (string-join result "\n"))
+
+(define (page-alias-row db alias-id)
+  (query-maybe-row db
+                   #<<SQL
+SELECT a.id, a.namespace, a.slug, a.title, a.page_id,
+       p.namespace, p.slug, p.title
+FROM page_aliases a
+JOIN pages p ON p.id = a.page_id
+WHERE a.id = $1 AND p.archived = FALSE
+SQL
+                   alias-id))
+
+(define (alias-current-reference-pages db alias-row)
+  (define old-namespace (vector-ref alias-row 1))
+  (define old-slug (vector-ref alias-row 2))
+  (define old-title (vector-ref alias-row 3))
+  (define new-namespace (vector-ref alias-row 5))
+  (define new-slug (vector-ref alias-row 6))
+  (define new-title (vector-ref alias-row 7))
+  (filter
+   (λ (item) (hash-ref item 'changed #f))
+   (for/list ((row (in-list
+                    (query-rows db
+                                "SELECT id, namespace, slug, title, markdown, current_version, tags FROM pages WHERE archived = FALSE ORDER BY lower(namespace), lower(title), title"))))
+     (define markdown (vector-ref row 4))
+     (define replaced
+       (replace-alias-reference markdown
+                                old-namespace old-slug old-title
+                                new-namespace new-slug new-title))
+     (hash 'id (vector-ref row 0)
+           'namespace (vector-ref row 1)
+           'pageSlug (vector-ref row 2)
+           'slug (page-reference (vector-ref row 1) (vector-ref row 2))
+           'title (vector-ref row 3)
+           'markdown markdown
+           'replacement replaced
+           'currentVersion (vector-ref row 5)
+           'tags (text->tags (vector-ref row 6))
+           'changed (not (string=? markdown replaced))))))
+
+(define (alias-historical-reference-pages db alias-row)
+  (define old-namespace (vector-ref alias-row 1))
+  (define old-slug (vector-ref alias-row 2))
+  (define old-title (vector-ref alias-row 3))
+  (define new-namespace (vector-ref alias-row 5))
+  (define new-slug (vector-ref alias-row 6))
+  (define new-title (vector-ref alias-row 7))
+  (filter
+   (λ (item) (hash-ref item 'changed #f))
+   (for/list ((row (in-list
+                    (query-rows db
+                                #<<SQL
+SELECT p.namespace, p.slug, p.title, pv.version, pv.markdown, pv.created_at
+FROM page_versions pv
+JOIN pages p ON p.id = pv.page_id
+ORDER BY pv.created_at DESC, pv.id DESC
+SQL
+                                ))))
+     (define markdown (vector-ref row 4))
+     (define replaced
+       (replace-alias-reference markdown
+                                old-namespace old-slug old-title
+                                new-namespace new-slug new-title))
+     (hash 'slug (page-reference (vector-ref row 0) (vector-ref row 1))
+           'title (vector-ref row 2)
+           'version (vector-ref row 3)
+           'createdAt (vector-ref row 5)
+           'changed (not (string=? markdown replaced))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Replace current references to one retained alias with its canonical page address.
+; pre    : alias-id identifies a retained alias and author is the administrator performing cleanup.
+; post   : Every changed current page receives a normal immutable version; history itself is untouched.
+; result : A hash containing the number of pages changed and historical references left untouched.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (cleanup-page-alias! config alias-id author)
+  (call-with-wiki-database
+   config
+   (λ (db)
+     (call-with-transaction
+      db
+      (λ ()
+        (define alias-row (page-alias-row db alias-id))
+        (unless alias-row
+          (error 'cleanup-page-alias! "unknown page alias: ~a" alias-id))
+        (define old-reference
+          (page-reference (vector-ref alias-row 1) (vector-ref alias-row 2)))
+        (define new-reference
+          (page-reference (vector-ref alias-row 5) (vector-ref alias-row 6)))
+        (define pages (alias-current-reference-pages db alias-row))
+        (define now (current-seconds))
+        (for ((page (in-list pages)))
+          (define page-id (hash-ref page 'id))
+          (define next-version (+ (hash-ref page 'currentVersion) 1))
+          (define markdown (hash-ref page 'replacement))
+          (define summary (format "Updated page alias ~a -> ~a" old-reference new-reference))
+          (query-exec db
+                      #<<SQL
+UPDATE pages
+SET markdown = $1, current_version = $2, updated_at = $3, updated_by = $4,
+    search_document = setweight(to_tsvector('simple', coalesce(title, '')), 'A') ||
+                      setweight(to_tsvector('simple', coalesce($1, '')), 'B')
+WHERE id = $5
+SQL
+                      markdown next-version now author page-id)
+          (define page-version-id
+            (insert-version! db page-id next-version
+                             (hash-ref page 'title) markdown author "alias-cleanup" summary now
+                             (hash-ref page 'tags)))
+          (replace-todos! db page-id markdown)
+          (replace-current-attachment-references! db page-id markdown now)
+          (record-version-attachment-references! db page-id page-version-id markdown now))
+        (hash 'changedPages (length pages)
+              'historicalReferences (length (alias-historical-reference-pages db alias-row))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Remove one retained page alias after current content no longer refers to it.
+; pre    : alias-id identifies an alias and no current page still contains a recognized old reference.
+; post   : The alias row is deleted; historical page versions are never modified.
+; result : void.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (delete-page-alias! config alias-id)
+  (call-with-wiki-database
+   config
+   (λ (db)
+     (call-with-transaction
+      db
+      (λ ()
+        (define alias-row (page-alias-row db alias-id))
+        (unless alias-row
+          (error 'delete-page-alias! "unknown page alias: ~a" alias-id))
+        (define current-pages (alias-current-reference-pages db alias-row))
+        (when (> (length current-pages) 0)
+          (error 'delete-page-alias! "page alias still has ~a current reference(s)" (length current-pages)))
+        (query-exec db "DELETE FROM page_aliases WHERE id = $1" alias-id)))))
+  (void))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : List retained page aliases and current pages that still contain the old reference.
+; pre    : PostgreSQL schema 8 or newer is initialized.
+; post   : Alias and page rows have only been read.
+; result : Newest-first alias hashes with canonical targets and literal reference pages.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (list-page-aliases config)
+  (call-with-wiki-database
+   config
+   (λ (db)
+     (for/list ((row (in-list
+                      (query-rows db
+                                  #<<SQL
+SELECT a.id, a.namespace, a.slug, a.title, a.created_at, a.created_by,
+       p.namespace, p.slug, p.title
+FROM page_aliases a
+JOIN pages p ON p.id = a.page_id
+WHERE p.archived = FALSE
+ORDER BY a.created_at DESC, a.id DESC
+SQL
+                                  ))))
+       (hash 'id (vector-ref row 0)
+             'namespace (vector-ref row 1)
+             'pageSlug (vector-ref row 2)
+             'title (vector-ref row 3)
+             'slug (page-reference (vector-ref row 1) (vector-ref row 2))
+             'createdAt (vector-ref row 4)
+             'createdBy (vector-ref row 5)
+             'targetNamespace (vector-ref row 6)
+             'targetPageSlug (vector-ref row 7)
+             'targetSlug (page-reference (vector-ref row 6) (vector-ref row 7))
+             'targetTitle (vector-ref row 8))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : List page aliases with current pages that still contain the old address.
+; pre    : PostgreSQL schema 8 or newer is initialized.
+; post   : Alias and current page rows have only been read.
+; result : Alias hashes augmented with a references list for administration.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (list-page-alias-details config)
+  (define aliases (list-page-aliases config))
+  (call-with-wiki-database
+   config
+   (λ (db)
+     (for/list ((alias (in-list aliases)))
+       (define alias-row (page-alias-row db (hash-ref alias 'id)))
+       (define current-references (alias-current-reference-pages db alias-row))
+       (define historical-references (alias-historical-reference-pages db alias-row))
+       (define with-references
+         (hash-set
+          alias
+          'references
+          (for/list ((page (in-list current-references)))
+            (hash 'slug (hash-ref page 'slug)
+                  'title (hash-ref page 'title)))))
+       (define with-history
+         (hash-set
+          with-references
+          'historicalReferences
+          (for/list ((page (in-list (take historical-references (min 10 (length historical-references))))))
+            (hash 'slug (hash-ref page 'slug)
+                  'title (hash-ref page 'title)
+                  'version (hash-ref page 'version)
+                  'createdAt (hash-ref page 'createdAt)))))
+       (hash-set with-history 'historicalReferenceCount (length historical-references))))))
+
+
 (define (safe-file-name name)
   (define clean
     (regexp-replace* #px"[^A-Za-z0-9._ -]" name "_"))
@@ -743,17 +1149,17 @@ SQL
        (call-with-wiki-database
         config
         (λ (db)
+          (define id (page-id/db db namespace slug))
           (define row
-            (query-maybe-row db
-                             #<<SQL
-SELECT a.original_name, a.stored_name, a.mime_type, a.content, a.size
-FROM attachments a
-JOIN pages p ON p.id = a.page_id
-WHERE p.slug = $1 AND p.archived = FALSE AND a.stored_name = $2
-ORDER BY CASE WHEN p.namespace = $3 THEN 0 ELSE 1 END, a.id
+            (and id
+                 (query-maybe-row db
+                                  #<<SQL
+SELECT original_name, stored_name, mime_type, content, size
+FROM attachments
+WHERE page_id = $1 AND stored_name = $2
 LIMIT 1
 SQL
-                             slug stored-name namespace))
+                                  id stored-name)))
           (if row
               (hash 'originalName (vector-ref row 0)
                     'storedName (vector-ref row 1)

private/vendor.rkt

@@ -17,10 +17,8 @@
 
 (define vendor-files
   (list
-   (cons "font-awesome/css/font-awesome.min.css"
-         "https://cdn.jsdelivr.net/npm/font-awesome@4.7.0/css/font-awesome.min.css")
-   (cons "font-awesome/fonts/fontawesome-webfont.woff2"
-         "https://cdn.jsdelivr.net/npm/font-awesome@4.7.0/fonts/fontawesome-webfont.woff2")
+   (cons "lucide.min.js"
+         "https://cdn.jsdelivr.net/npm/lucide@1.31.0/dist/umd/lucide.min.js")
    (cons "easymde.min.js"
          "https://cdn.jsdelivr.net/npm/easymde@2.21.0/dist/easymde.min.js")
    (cons "easymde.min.css"

private/version.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Single source for the racket-wiki software version.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require racket/runtime-path
+         setup/getinfo
+         )
+
+(provide racket-wiki-version)
+
+(define-runtime-path info-path "..")
+
+(define racket-wiki-version
+  (let ((info (get-info/full info-path)))
+    (info 'version)))
+