472 lines
17 KiB
Racket
472 lines
17 KiB
Racket
#lang racket/base
|
|
|
|
(require db
|
|
json
|
|
racket/file
|
|
racket/list
|
|
racket/path
|
|
racket/string
|
|
"config.rkt"
|
|
"database.rkt"
|
|
"todo.rkt")
|
|
|
|
(provide ensure-wiki-data!
|
|
valid-slug?
|
|
title->slug
|
|
list-pages
|
|
read-page
|
|
create-page!
|
|
update-page!
|
|
archive-page!
|
|
page-history
|
|
read-version
|
|
search-pages
|
|
list-todos
|
|
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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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 '("." "..")))))
|
|
|
|
(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 result
|
|
(hash 'slug (vector-ref row 0)
|
|
'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")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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(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 slug)
|
|
(if (not (valid-slug? slug))
|
|
#f
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define row
|
|
(query-maybe-row db
|
|
(string-append "SELECT " page-columns
|
|
" FROM pages WHERE slug = $1 AND archived = FALSE")
|
|
slug))
|
|
(if row (row->page 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-exec 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)
|
|
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 slug title markdown author [summary "Created page"] [tags '()])
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(define now (current-seconds))
|
|
(define page-id
|
|
(query-value db
|
|
#<<SQL
|
|
INSERT INTO pages(slug, title, markdown, tags, current_version,
|
|
created_at, updated_at, created_by, updated_by, search_document)
|
|
VALUES ($1, $2, $3, $4, 1, $5, $5, $6, $6,
|
|
setweight(to_tsvector('simple', coalesce($2, '')), 'A') ||
|
|
setweight(to_tsvector('simple', coalesce($3, '')), 'B'))
|
|
RETURNING id
|
|
SQL
|
|
slug title markdown (tags->text tags) now author))
|
|
(insert-version! db page-id 1 title markdown author "create" summary now tags)
|
|
(replace-todos! db page-id markdown)))))
|
|
(read-page config slug))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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 slug title markdown author base-version [summary "Edited page"] [tags #f])
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(define row
|
|
(query-maybe-row db
|
|
"SELECT id, current_version, tags FROM pages WHERE slug = $1 AND archived = FALSE FOR UPDATE"
|
|
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 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,
|
|
search_document = setweight(to_tsvector('simple', coalesce($1, '')), 'A') ||
|
|
setweight(to_tsvector('simple', coalesce($2, '')), 'B')
|
|
WHERE id = $7
|
|
SQL
|
|
title markdown (tags->text page-tags) next-version now author (vector-ref row 0))
|
|
(insert-version! db (vector-ref row 0) next-version title markdown author "edit" summary now page-tags)
|
|
(replace-todos! db (vector-ref row 0) markdown)))))
|
|
(read-page config 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 slug author)
|
|
(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 slug = $3 AND archived = FALSE
|
|
RETURNING id
|
|
SQL
|
|
(current-seconds) author slug))
|
|
(unless id
|
|
(error 'archive-page! "unknown page: ~a" slug))))
|
|
(void))
|
|
|
|
(define (page-id config slug)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(query-maybe-value db
|
|
"SELECT id FROM pages WHERE slug = $1 AND archived = FALSE"
|
|
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 slug)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define id
|
|
(query-maybe-value db "SELECT id FROM pages WHERE slug = $1 AND archived = FALSE" 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 slug version)
|
|
(define version-number
|
|
(if (number? version) version (string->number version)))
|
|
(and version-number
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(define row
|
|
(query-maybe-row db
|
|
#<<SQL
|
|
SELECT 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.slug = $1 AND p.archived = FALSE AND v.version = $2
|
|
SQL
|
|
slug 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
|
|
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 (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'rank (vector-ref row 2)
|
|
'snippet (vector-ref row 3)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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
|
|
FROM todo_items t
|
|
JOIN pages p ON p.id = t.page_id
|
|
WHERE p.archived = FALSE
|
|
ORDER BY lower(p.title), p.title, t.item_number
|
|
SQL
|
|
))))
|
|
(hash 'slug (vector-ref row 0)
|
|
'title (vector-ref row 1)
|
|
'number (vector-ref row 2)
|
|
'line (vector-ref row 3)
|
|
'text (vector-ref row 4))))))
|
|
|
|
(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 slug original-name content author)
|
|
(define id (page-id config slug))
|
|
(unless id
|
|
(error 'save-upload! "unknown page: ~a" slug))
|
|
(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" slug 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 slug stored-name)
|
|
(and (valid-slug? slug)
|
|
(not (regexp-match? #px"[/\\\\]" stored-name))
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(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
|
|
SQL
|
|
slug 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)))))
|