#lang racket/base

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PostgreSQL-backed page, history, search, bookmark and upload storage.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require db
         json
         racket/file
         racket/list
         racket/path
         racket/string
         "attachment-references.rkt"
         "config.rkt"
         "database.rkt"
         "todo.rkt")

(provide ensure-wiki-data!
         valid-slug?
         valid-page-reference?
         page-reference
         split-page-reference
         title->slug
         list-pages
         read-page
         create-page!
         update-page!
         rename-page!
         archive-page!
         page-history
         read-version
         search-pages
         list-todos
         list-recent-pages
         list-bookmarks
         set-bookmark!
         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)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Ensure writable installation directories exist.
; pre    : config is a wiki-config value and its data directory is writable.
; post   : The data directory and writable static directory exist.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ensure-wiki-data! config)
  (for ((directory (in-list (list (wiki-config-data-dir config)
                                  (data-static-directory config)))))
    (make-directory* directory)))

(define (slug-alphanumeric? char)
  (or (char-alphabetic? char)
      (char-numeric? char)))

(define (combining-mark? char)
  (if (member (char-general-category char) '(mn mc me))
      #t
      #f))

(define (valid-slug-character? char)
  (or (slug-alphanumeric? char)
      (char=? char #\.)
      (char=? char #\_)
      (char=? char #\-)))

(define (valid-slug? slug)
  (and (> (string-length slug) 0)
       (<= (string-length slug) 120)
       (slug-alphanumeric? (string-ref slug 0))
       (for/and ((char (in-string slug)))
         (valid-slug-character? char))
       (not (member slug '("." "..")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Build the external wiki reference for a namespace and slug.
; pre    : namespace and slug are strings; slug is a valid page slug.
; post   : No state is changed.
; result : slug for the root namespace, otherwise namespace:slug.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (page-reference namespace slug)
  (if (string=? (string-trim namespace) "")
      slug
      (string-append (string-trim namespace) ":" slug)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Split an external page reference into namespace and slug.
; pre    : reference is a string.
; post   : No state is changed.
; result : Two values: namespace and slug. The namespace is empty for root pages.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (split-page-reference reference)
  (define match (regexp-match #px"^([^:]+):(.*)$" reference))
  (if match
      (values (list-ref match 1) (list-ref match 2))
      (values "" reference)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Check whether a namespace-qualified page reference is valid.
; pre    : reference is a string.
; post   : No state is changed.
; result : #t for root slugs or namespace:slug references with letter/number namespaces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (valid-page-reference? reference)
  (define-values (namespace slug) (split-page-reference reference))
  (and (valid-slug? slug)
       (or (string=? namespace "")
           (and (valid-slug? namespace)
                (<= (string-length namespace) 80)))))

(define (title->slug title)
  (define normalized
    (string-downcase
     (string-normalize-nfkd (string-trim title))))
  (define out (open-output-string))
  (define separator-needed? #f)
  (define wrote-character? #f)
  (for ((char (in-string normalized)))
    (cond
      ((slug-alphanumeric? char)
       (when (and separator-needed? wrote-character?)
         (write-char #\- out))
       (write-char char out)
       (set! separator-needed? #f)
       (set! wrote-character? #t))
      ((combining-mark? char)
       (void))
      (else
       (set! separator-needed? #t))))
  (define slug (get-output-string out))
  (define limited
    (if (> (string-length slug) 120)
        (substring slug 0 120)
        slug))
  (regexp-replace #px"-+$" limited ""))

(define (tags->text tags)
  (jsexpr->string tags))

(define (text->tags text)
  (with-handlers ((exn:fail? (λ (_e) '())))
    (define value (string->jsexpr text))
    (if (list? value) value '())))

(define (row->page row [include-markdown? #t])
  (define namespace (vector-ref row 9))
  (define slug (vector-ref row 0))
  (define result
    (hash 'slug (page-reference namespace slug)
          'pageSlug slug
          'namespace namespace
          'title (vector-ref row 1)
          'createdAt (vector-ref row 3)
          'updatedAt (vector-ref row 4)
          'createdBy (vector-ref row 5)
          'updatedBy (vector-ref row 6)
          'tags (text->tags (vector-ref row 7))
          'currentVersion (vector-ref row 8)))
  (if include-markdown?
      (hash-set result 'markdown (vector-ref row 2))
      result))

(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.
; post   : The pages table has only been read.
; result : A title-sorted list of page metadata hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-pages config)
  (call-with-wiki-database
   config
   (λ (db)
     (for/list ((row (in-list
                      (query-rows db
                                  (string-append "SELECT " page-columns
                                                 " FROM pages WHERE archived = FALSE ORDER BY lower(namespace), namespace, lower(title), title")))))
       (row->page row #f)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read the current form of one wiki page.
; pre    : slug is a valid page slug.
; post   : The pages table has only been read.
; result : Page metadata with Markdown, or #f when the page does not exist.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-page config reference)
  (if (not (valid-page-reference? reference))
      #f
      (let-values (((namespace slug) (split-page-reference reference)))
        (call-with-wiki-database
         config
         (λ (db)
           (define row
             (query-maybe-row db
                              (string-append "SELECT " page-columns
                                             " FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE")
                              namespace slug))
           (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)
  (for ((item (in-list (extract-todos markdown))))
    (query-exec db
                "INSERT INTO todo_items(page_id, item_number, line_number, text) VALUES ($1, $2, $3, $4)"
                page-id
                (hash-ref item 'number)
                (hash-ref item 'line)
                (hash-ref item 'text))))

(define (insert-version! db page-id version title markdown author action summary now tags)
  (query-value db
               #<<SQL
INSERT INTO page_versions(page_id, version, title, markdown, tags, author, action, summary, created_at)
VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9)
RETURNING id
SQL
               page-id version title markdown (tags->text tags) author action summary now))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a wiki page and its first version.
; pre    : slug is valid and unused.
; post   : Current page state and version 1 are committed atomically.
; result : The new page metadata with Markdown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-page! config reference title markdown author [summary "Created page"] [tags '()])
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (call-with-transaction
      db
      (λ ()
        (define now (current-seconds))
        (define page-id
          (query-value db
                       #<<SQL
INSERT INTO pages(namespace, slug, title, markdown, tags, current_version,
                  created_at, updated_at, created_by, updated_by, search_document)
VALUES ($1, $2, $3, $4, $5, 1, $6, $6, $7, $7,
        setweight(to_tsvector('simple', coalesce($3, '')), 'A') ||
        setweight(to_tsvector('simple', coalesce($4, '')), 'B'))
RETURNING id
SQL
                       namespace slug title markdown (tags->text tags) now author))
        (define page-version-id
          (insert-version! db page-id 1 title markdown author "create" summary now 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)))))
  (read-page config reference))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Save a new version of an existing wiki page.
; pre    : The page exists and base-version equals its current version.
; post   : Current page and version history are committed atomically.
; result : The updated page metadata with Markdown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-page! config reference title markdown author base-version [summary "Edited page"] [tags #f] [new-namespace #f])
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (call-with-transaction
      db
      (λ ()
        (define row
          (query-maybe-row db
                           "SELECT id, current_version, tags, namespace FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
                           namespace slug))
        (unless row
          (error 'update-page! "unknown page: ~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 (= current-version supplied-version))
          (error 'update-page! "version-conflict"))
        (define page-tags
          (if tags tags (text->tags (vector-ref row 2))))
        (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
                    #<<SQL
UPDATE pages
SET title = $1, markdown = $2, tags = $3, current_version = $4,
    updated_at = $5, updated_by = $6, namespace = $7,
    search_document = setweight(to_tsvector('simple', coalesce($1, '')), 'A') ||
                      setweight(to_tsvector('simple', coalesce($2, '')), 'B')
WHERE id = $8
SQL
                    title markdown (tags->text page-tags) next-version now author target-namespace (vector-ref row 0))
        (define page-id (vector-ref row 0))
        (define page-version-id
          (insert-version! db page-id next-version title markdown author "edit" summary now 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)))))
  (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.
; pre    : The page exists.
; post   : The page is marked archived while its versions and attachments remain stored.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (archive-page! config reference author)
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (define id
       (query-maybe-value db
                          #<<SQL
UPDATE pages
SET archived = TRUE, archived_at = $1, archived_by = $2
WHERE namespace = $3 AND slug = $4 AND archived = FALSE
RETURNING id
SQL
                          (current-seconds) author namespace slug))
     (unless id
       (error 'archive-page! "unknown page: ~a" slug))
     (query-exec db
                 "DELETE FROM attachment_references WHERE page_id = $1 AND current_reference = TRUE"
                 id)))
  (void))

(define (page-id config reference)
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (page-id/db db namespace slug))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read the version history for a wiki page.
; pre    : The page exists.
; post   : Page version rows have only been read.
; result : A newest-first list of version metadata hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (page-history config reference)
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (define id (page-id/db db namespace slug))
     (unless id
       (error 'page-history "unknown page: ~a" slug))
     (for/list ((row (in-list
                      (query-rows db
                                  #<<SQL
SELECT version, title, author, action, summary, tags, created_at
FROM page_versions
WHERE page_id = $1
ORDER BY version DESC
SQL
                                  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)
             'tags (text->tags (vector-ref row 5))
             'createdAt (vector-ref row 6))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read one stored page version.
; pre    : slug and version identify a possible stored version.
; post   : Version rows have only been read.
; result : Version metadata with Markdown, or #f when the version is absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-version config reference version)
  (define-values (namespace slug) (split-page-reference reference))
  (define version-number
    (if (number? version) version (string->number version)))
  (and version-number
       (call-with-wiki-database
        config
        (λ (db)
          (define id (page-id/db db namespace slug))
          (define row
            (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
                                  id version-number)))
          (and row
               (hash 'version (vector-ref row 0)
                     'title (vector-ref row 1)
                     'markdown (vector-ref row 2)
                     'author (vector-ref row 3)
                     'action (vector-ref row 4)
                     'summary (vector-ref row 5)
                     'tags (text->tags (vector-ref row 6))
                     'createdAt (vector-ref row 7)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Search current wiki pages using PostgreSQL full-text search.
; pre    : query-text is a string and the database schema is initialized.
; post   : Page content has only been read.
; result : Up to 50 relevance-sorted search result hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (search-pages 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)
SELECT p.slug,
       p.title,
       ts_rank(p.search_document, q.query) AS rank,
       ts_headline('simple', p.markdown, q.query,
                   'StartSel=[[[, StopSel=]]], MaxWords=28, MinWords=8, ShortWord=2') AS snippet,
       p.namespace
FROM pages p, q
WHERE p.archived = FALSE
  AND p.search_document @@ q.query
ORDER BY rank DESC, lower(p.title), p.title
LIMIT 50
SQL
                                      query-text))))
           (hash 'slug (page-reference (vector-ref row 4) (vector-ref row 0))
                 'namespace (vector-ref row 4)
                 'title (vector-ref row 1)
                 'rank (vector-ref row 2)
                 'snippet (vector-ref row 3)
                 'type "page"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List unresolved todo(...) markers from all current wiki pages.
; pre    : PostgreSQL schema 3 or newer is initialized.
; post   : Todo and page rows have only been read.
; result : A page/title sorted list of todo item hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-todos config)
  (call-with-wiki-database
   config
   (λ (db)
     (for/list ((row (in-list
                      (query-rows db
                                  #<<SQL
SELECT p.slug, p.title, t.item_number, t.line_number, t.text, p.namespace
FROM todo_items t
JOIN pages p ON p.id = t.page_id
WHERE p.archived = FALSE
ORDER BY lower(p.namespace), p.namespace, lower(p.title), p.title, t.item_number
SQL
                                  ))))
       (hash 'slug (page-reference (vector-ref row 5) (vector-ref row 0))
             'namespace (vector-ref row 5)
             'title (vector-ref row 1)
             'number (vector-ref row 2)
             'line (vector-ref row 3)
             'text (vector-ref row 4))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List recently edited current wiki pages.
; pre    : PostgreSQL schema 1 or newer is initialized.
; post   : Page rows have only been read.
; result : At most limit page metadata hashes, newest first.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-recent-pages config [limit 50])
  (call-with-wiki-database
   config
   (λ (db)
     (for/list ((row (in-list
                      (query-rows db
                                  (string-append "SELECT " page-columns
                                                 " FROM pages WHERE archived = FALSE"
                                                 " ORDER BY updated_at DESC, lower(title), title"
                                                 " LIMIT $1")
                                  limit))))
       (row->page row #f)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List bookmarks for one wiki user.
; pre    : PostgreSQL schema 4 or newer is initialized and user-id identifies a user.
; post   : Bookmark and page rows have only been read.
; result : Bookmarks ordered by section and position.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-bookmarks config user-id)
  (call-with-wiki-database
   config
   (λ (db)
     (for/list ((row (in-list
                      (query-rows db
                                  #<<SQL
SELECT p.slug, p.title, b.section, b.position, b.created_at, p.updated_at, p.namespace
FROM bookmarks b
JOIN pages p ON p.id = b.page_id
WHERE b.user_id = $1
  AND p.archived = FALSE
ORDER BY lower(p.namespace), p.namespace, lower(b.section), b.section, b.position, b.created_at, lower(p.title), p.title
SQL
                                  user-id))))
       (hash 'slug (page-reference (vector-ref row 6) (vector-ref row 0))
             'namespace (vector-ref row 6)
             'title (vector-ref row 1)
             'section (vector-ref row 2)
             'position (vector-ref row 3)
             'createdAt (vector-ref row 4)
             'updatedAt (vector-ref row 5))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Add a page to a user's bookmarks or move it to another section.
; pre    : PostgreSQL schema 4 or newer is initialized and slug identifies a current page.
; post   : Exactly one bookmark exists for user-id and the page.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-bookmark! config user-id reference section)
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (call-with-transaction
      db
      (λ ()
        (define page-id
          (query-maybe-value db
                             "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
                             namespace slug))
        (unless page-id
          (error 'set-bookmark! "unknown page: ~a" slug))
        (define clean-section (string-trim section))
        (define position
          (query-value db
                       #<<SQL
SELECT COALESCE(MAX(position), -1) + 1
FROM bookmarks
WHERE user_id = $1 AND section = $2
SQL
                       user-id
                       clean-section))
        (query-exec db
                    #<<SQL
INSERT INTO bookmarks(user_id, page_id, section, position, created_at)
VALUES ($1, $2, $3, $4, $5)
ON CONFLICT (user_id, page_id)
DO UPDATE SET section = EXCLUDED.section, position = EXCLUDED.position
SQL
                    user-id page-id clean-section position (current-seconds))))))
  (void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Remove one page from a user's bookmarks.
; pre    : PostgreSQL schema 4 or newer is initialized.
; post   : The bookmark no longer exists; other bookmarks are unchanged.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (delete-bookmark! config user-id reference)
  (define-values (namespace slug) (split-page-reference reference))
  (call-with-wiki-database
   config
   (λ (db)
     (query-exec db
                 #<<SQL
DELETE FROM bookmarks
WHERE user_id = $1
  AND page_id = (SELECT id FROM pages WHERE namespace = $2 AND slug = $3)
SQL
                 user-id namespace slug)))
  (void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List uploads that no current page references.
; pre    : PostgreSQL schema 6 or newer is initialized.
; post   : Attachment and reference rows have only been read.
; result : A newest-first list with owner and last historical use metadata.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-orphaned-uploads config)
  (call-with-wiki-database
   config
   (λ (db)
     (for/list ((row (in-list
                      (query-rows db
                                  #<<SQL
SELECT a.id,
       a.original_name,
       a.stored_name,
       a.mime_type,
       a.size,
       a.uploaded_at,
       a.uploaded_by,
       owner.slug,
       owner.title,
       owner.namespace
FROM attachments a
JOIN pages owner ON owner.id = a.page_id
WHERE NOT EXISTS (
  SELECT 1
  FROM attachment_references current_ref
  WHERE current_ref.attachment_id = a.id
    AND current_ref.current_reference = TRUE
)
ORDER BY a.uploaded_at DESC, a.id DESC
SQL
                                  ))))
       (define attachment-id (vector-ref row 0))
       (define last-uses
         (for/list ((use-row (in-list
                              (query-rows db
                                          #<<SQL
SELECT p.slug, p.title, pv.version, ar.referenced_at, p.namespace
FROM attachment_references ar
JOIN pages p ON p.id = ar.page_id
LEFT JOIN page_versions pv ON pv.id = ar.page_version_id
WHERE ar.attachment_id = $1
  AND ar.current_reference = FALSE
ORDER BY ar.referenced_at DESC, ar.id DESC
LIMIT 5
SQL
                                          attachment-id))))
           (hash 'slug (page-reference (vector-ref use-row 4) (vector-ref use-row 0))
                 'namespace (vector-ref use-row 4)
                 'title (vector-ref use-row 1)
                 'version (if (sql-null? (vector-ref use-row 2)) #f (vector-ref use-row 2))
                 'referencedAt (vector-ref use-row 3))))
       (hash 'id attachment-id
             'originalName (vector-ref row 1)
             'storedName (vector-ref row 2)
             'mimeType (vector-ref row 3)
             'size (vector-ref row 4)
             'uploadedAt (vector-ref row 5)
             'uploadedBy (vector-ref row 6)
             'ownerSlug (page-reference (vector-ref row 9) (vector-ref row 7))
             'ownerNamespace (vector-ref row 9)
             'ownerTitle (vector-ref row 8)
             'lastUses last-uses)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Delete an upload only when no current page references it.
; pre    : attachment-id identifies a possible attachment.
; post   : The attachment and its reference rows are deleted, or an error is raised.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (delete-orphaned-upload! config attachment-id)
  (call-with-wiki-database
   config
   (λ (db)
     (call-with-transaction
      db
      (λ ()
        (define current-count
          (query-value db
                       "SELECT COUNT(*) FROM attachment_references WHERE attachment_id = $1 AND current_reference = TRUE"
                       attachment-id))
        (when (> current-count 0)
          (error 'delete-orphaned-upload! "attachment is still referenced by a current page"))
        (define deleted-id
          (query-maybe-value db
                             "DELETE FROM attachments WHERE id = $1 RETURNING id"
                             attachment-id))
        (unless deleted-id
          (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 "_"))
  (if (or (string=? clean "")
          (string=? clean ".")
          (string=? clean ".."))
      "upload.bin"
      clean))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Store an uploaded file in PostgreSQL.
; pre    : The page exists and content is a byte string.
; post   : Attachment metadata and bytes are stored in one PostgreSQL row.
; result : A hash containing original name, stored name and page-local URL.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (save-upload! config reference original-name content author)
  (define id (page-id config reference))
  (unless id
    (error 'save-upload! "unknown page: ~a" reference))
  (define stored-name
    (format "~a-~a-~a" (current-seconds) (random 1000000) (safe-file-name original-name)))
  (define mime-type
    (cond
      ((regexp-match? #px"(?i:[.]png)$" stored-name) "image/png")
      ((regexp-match? #px"(?i:[.](jpg|jpeg))$" stored-name) "image/jpeg")
      ((regexp-match? #px"(?i:[.]gif)$" stored-name) "image/gif")
      ((regexp-match? #px"(?i:[.]webp)$" stored-name) "image/webp")
      ((regexp-match? #px"(?i:[.]pdf)$" stored-name) "application/pdf")
      ((regexp-match? #px"(?i:[.]txt)$" stored-name) "text/plain; charset=utf-8")
      (else "application/octet-stream")))
  (call-with-wiki-database
   config
   (λ (db)
     (query-exec db
                 #<<SQL
INSERT INTO attachments(page_id, original_name, stored_name, mime_type, content,
                        size, uploaded_at, uploaded_by)
VALUES ($1, $2, $3, $4, $5, $6, $7, $8)
SQL
                 id
                 original-name
                 stored-name
                 mime-type
                 content
                 (bytes-length content)
                 (current-seconds)
                 author)))
  (hash 'name original-name
        'storedName stored-name
        'url (format "/uploads/~a/~a" reference stored-name)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read one stored attachment from PostgreSQL.
; pre    : slug and stored-name come from an upload request path.
; post   : PostgreSQL has only been read.
; result : A hash containing bytes, MIME type and names, or #f when absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (uploaded-file config reference stored-name)
  (define-values (namespace slug) (split-page-reference reference))
  (and (valid-page-reference? reference)
       (not (regexp-match? #px"[/\\\\]" stored-name))
       (call-with-wiki-database
        config
        (λ (db)
          (define id (page-id/db db namespace slug))
          (define row
            (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
                                  id stored-name)))
          (if row
              (hash 'originalName (vector-ref row 0)
                    'storedName (vector-ref row 1)
                    'mimeType (vector-ref row 2)
                    'content (vector-ref row 3)
                    'size (vector-ref row 4))
              #f)))))