refactoring by skill
This commit is contained in:
+263
-252
@@ -50,15 +50,15 @@
|
||||
; 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)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (slug-alphanumeric? char)
|
||||
(or (char-alphabetic? char)
|
||||
(char-numeric? char)))
|
||||
@@ -74,6 +74,12 @@
|
||||
(char=? char #\_)
|
||||
(char=? char #\-)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether a string is a valid page or namespace slug.
|
||||
; pre : slug is a string.
|
||||
; post : No state is changed.
|
||||
; result : #t for a non-special slug of at most 120 supported characters.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (valid-slug? slug)
|
||||
(and (> (string-length slug) 0)
|
||||
(<= (string-length slug) 120)
|
||||
@@ -100,10 +106,10 @@
|
||||
; 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)))
|
||||
(let ((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.
|
||||
@@ -112,63 +118,69 @@
|
||||
; 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)))))
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(and (valid-slug? slug)
|
||||
(or (string=? namespace "")
|
||||
(and (valid-slug? namespace)
|
||||
(<= (string-length namespace) 80))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Derive a stable page slug from a human-readable title.
|
||||
; pre : title is a string.
|
||||
; post : No state is changed.
|
||||
; result : A lowercase, normalized slug containing at most 120 characters.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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 ""))
|
||||
(let ((normalized
|
||||
(string-downcase
|
||||
(string-normalize-nfkd (string-trim title))))
|
||||
(out (open-output-string))
|
||||
(separator-needed? #f)
|
||||
(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))))
|
||||
(let* ((slug (get-output-string out))
|
||||
(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 '())))
|
||||
(let ((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))
|
||||
(let* ((namespace (vector-ref row 9))
|
||||
(slug (vector-ref row 0))
|
||||
(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")
|
||||
@@ -177,20 +189,20 @@
|
||||
"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
|
||||
(let ((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)))
|
||||
namespace slug))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List current wiki page metadata.
|
||||
@@ -221,21 +233,21 @@ SQL
|
||||
(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))))))
|
||||
(let* ((row
|
||||
(query-maybe-row db
|
||||
(string-append "SELECT " page-columns
|
||||
" FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE")
|
||||
namespace slug))
|
||||
(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)
|
||||
@@ -263,17 +275,17 @@ SQL
|
||||
; 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
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(let* ((now (current-seconds))
|
||||
(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,
|
||||
@@ -281,13 +293,13 @@ VALUES ($1, $2, $3, $4, $5, 1, $6, $6, $7, $7,
|
||||
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))
|
||||
namespace slug title markdown (tags->text tags) now author))
|
||||
(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.
|
||||
@@ -296,36 +308,35 @@ SQL
|
||||
; 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
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(let ((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))
|
||||
(let* ((current-version (vector-ref row 1))
|
||||
(supplied-version
|
||||
(if (number? base-version)
|
||||
base-version
|
||||
(string->number (format "~a" base-version))))
|
||||
(page-tags (if tags tags (text->tags (vector-ref row 2))))
|
||||
(target-namespace (vector-ref row 3))
|
||||
(next-version (+ current-version 1))
|
||||
(now (current-seconds)))
|
||||
(unless (and supplied-version (= current-version supplied-version))
|
||||
(error 'update-page! "version-conflict"))
|
||||
(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"))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
UPDATE pages
|
||||
SET title = $1, markdown = $2, tags = $3, current_version = $4,
|
||||
updated_at = $5, updated_by = $6, namespace = $7,
|
||||
@@ -333,14 +344,14 @@ SET title = $1, markdown = $2, tags = $3, current_version = $4,
|
||||
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)))
|
||||
title markdown (tags->text page-tags) next-version now author target-namespace (vector-ref row 0))
|
||||
(let* ((page-id (vector-ref row 0))
|
||||
(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.
|
||||
@@ -350,63 +361,63 @@ SQL
|
||||
; 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
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(let ((clean-namespace (string-trim target-namespace))
|
||||
(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
|
||||
(λ ()
|
||||
(let ((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))
|
||||
(let* ((page-id (vector-ref row 0))
|
||||
(old-title (vector-ref row 1))
|
||||
(markdown (vector-ref row 2))
|
||||
(tags (text->tags (vector-ref row 3)))
|
||||
(current-version (vector-ref row 4))
|
||||
(address-changed?
|
||||
(or (not (string=? namespace clean-namespace))
|
||||
(not (string=? slug clean-slug)))))
|
||||
(when address-changed?
|
||||
(let ((target-page-id
|
||||
(query-maybe-value db
|
||||
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
|
||||
clean-namespace clean-slug))
|
||||
(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-page-id (not (= target-page-id page-id)))
|
||||
(error 'rename-page! "page address is already in use: ~a"
|
||||
(page-reference 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
|
||||
namespace slug old-title page-id (current-seconds) author)))
|
||||
(let ((next-version (+ current-version 1))
|
||||
(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,
|
||||
@@ -414,11 +425,11 @@ SET namespace = $1, slug = $2, title = $3, current_version = $4,
|
||||
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)))
|
||||
clean-namespace clean-slug title next-version now author page-id)
|
||||
(let ((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.
|
||||
@@ -427,32 +438,32 @@ SQL
|
||||
; 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
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((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))
|
||||
(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))))
|
||||
(let-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.
|
||||
@@ -461,29 +472,29 @@ SQL
|
||||
; 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
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((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))))))
|
||||
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.
|
||||
@@ -492,32 +503,32 @@ SQL
|
||||
; 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
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(let ((version-number
|
||||
(if (number? version) version (string->number version))))
|
||||
(and version-number
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let* ((id (page-id/db db namespace slug))
|
||||
(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)))))))
|
||||
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.
|
||||
|
||||
Reference in New Issue
Block a user