hans/racket-wiki
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactoring by skill

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-29 22:22:49 +02:00
parent 67fce7a330
commit 649ff0d7c5
22 changed files with 1598 additions and 1644 deletions
Download Patch File Download Diff File Expand all files Collapse all files
architecture/import.rkt
+220 -224
View File
@@ -62,30 +62,30 @@
(define (canonical-datum value)
(cond
[(hash? value)
(define keys
(sort (hash-keys value)
string<?
#:key (λ (key) (format "~a" key))))
(for/list ([key (in-list keys)])
(list key (canonical-datum (hash-ref value key))))]
(let ((keys
(sort (hash-keys value)
string<?
#:key (λ (key) (format "~a" key)))))
(for/list ([key (in-list keys)])
(list key (canonical-datum (hash-ref value key)))))]
[(list? value)
(for/list ([item (in-list value)])
(canonical-datum item))]
[else value]))
(define (source-hash value)
(define source-bytes
(string->bytes/utf-8
(format "~s" (canonical-datum value))))
(bytes->hex-string (sha256-bytes source-bytes)))
(let ((source-bytes
(string->bytes/utf-8
(format "~s" (canonical-datum value)))))
(bytes->hex-string (sha256-bytes source-bytes))))
(define (read-page-source namespace specification)
(define slug (hash-ref specification 'slug))
(architecture-page
(page-reference namespace slug)
(hash-ref specification 'title)
(file->string (content-path (hash-ref specification 'file)))
(hash-ref specification 'tags '())))
(let ((slug (hash-ref specification 'slug)))
(architecture-page
(page-reference namespace slug)
(hash-ref specification 'title)
(file->string (content-path (hash-ref specification 'file)))
(hash-ref specification 'tags '()))))
(define (read-concept-map-source specification)
(architecture-concept-map
@@ -96,109 +96,107 @@
read-json)))
(define (load-architecture-content)
(define manifest (read-manifest))
(unless (hash? manifest)
(error 'load-architecture-content "manifest.rktd must contain a hash"))
(define namespace (hash-ref manifest 'namespace))
(define pages
(for/list ([specification (in-list (hash-ref manifest 'pages))])
(read-page-source namespace specification)))
(define concept-maps
(for/list ([specification (in-list (hash-ref manifest 'concept-maps))])
(read-concept-map-source specification)))
(values namespace pages concept-maps))
(let ((manifest (read-manifest)))
(unless (hash? manifest)
(error 'load-architecture-content "manifest.rktd must contain a hash"))
(let* ((namespace (hash-ref manifest 'namespace))
(pages
(for/list ([specification (in-list (hash-ref manifest 'pages))])
(read-page-source namespace specification)))
(concept-maps
(for/list ([specification (in-list (hash-ref manifest 'concept-maps))])
(read-concept-map-source specification))))
(values namespace pages concept-maps))))
(define (duplicate-values values)
(define seen (mutable-set))
(define duplicates (mutable-set))
(for ([value (in-list values)])
(if (set-member? seen value)
(set-add! duplicates value)
(set-add! seen value)))
(sort (set->list duplicates) string<?))
(let ((seen (mutable-set))
(duplicates (mutable-set)))
(for ([value (in-list values)])
(if (set-member? seen value)
(set-add! duplicates value)
(set-add! seen value)))
(sort (set->list duplicates) string<?)))
(define (validate-page-links! page page-references concept-map-slugs)
(define markdown (architecture-page-markdown page))
(define linked-pages
(regexp-match*
#px"\\]\\((racket-wiki:[^)#]+)(?:#[^)]*)?\\)"
markdown
#:match-select (λ (match) (list-ref match 1))))
(define embedded-concept-maps
(for/list ([line (in-list (string-split markdown "\n" #:trim? #f))]
#:do [(define match
(regexp-match
concept-map-embed-pattern
line))]
#:when match)
(string-trim (list-ref match 1))))
(for ([reference (in-list linked-pages)])
(unless (set-member? page-references reference)
(error 'validate-racket-wiki-architecture!
"page ~a links to unknown architecture page ~a"
(architecture-page-reference page)
reference)))
(for ([slug (in-list embedded-concept-maps)])
(unless (set-member? concept-map-slugs slug)
(error 'validate-racket-wiki-architecture!
"page ~a embeds unknown architecture CMap ~a"
(architecture-page-reference page)
slug))))
(let* ((markdown (architecture-page-markdown page))
(linked-pages
(regexp-match*
#px"\\]\\((racket-wiki:[^)#]+)(?:#[^)]*)?\\)"
markdown
#:match-select (λ (match) (list-ref match 1))))
(embedded-concept-maps
(filter-map
(λ (line)
(let ((match (regexp-match concept-map-embed-pattern line)))
(and match (string-trim (list-ref match 1)))))
(string-split markdown "\n" #:trim? #f))))
(for ([reference (in-list linked-pages)])
(unless (set-member? page-references reference)
(error 'validate-racket-wiki-architecture!
"page ~a links to unknown architecture page ~a"
(architecture-page-reference page)
reference)))
(for ([slug (in-list embedded-concept-maps)])
(unless (set-member? concept-map-slugs slug)
(error 'validate-racket-wiki-architecture!
"page ~a embeds unknown architecture CMap ~a"
(architecture-page-reference page)
slug)))))
(define (validate-concept-map! concept-map page-references)
(define document (architecture-concept-map-document concept-map))
(unless (hash? document)
(error 'validate-racket-wiki-architecture!
"CMap ~a is not a JSON object"
(architecture-concept-map-slug concept-map)))
(unless (equal? (hash-ref document 'schemaVersion #f) 1)
(error 'validate-racket-wiki-architecture!
"CMap ~a does not use schema version 1"
(architecture-concept-map-slug concept-map)))
(define items (hash-ref document 'items '()))
(define connectors (hash-ref document 'connectors '()))
(unless (and (list? items) (list? connectors))
(error 'validate-racket-wiki-architecture!
"CMap ~a must contain item and connector arrays"
(architecture-concept-map-slug concept-map)))
(define item-ids
(for/list ([item (in-list items)])
(unless (hash? item)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains a non-object item"
(architecture-concept-map-slug concept-map)))
(define item-id (hash-ref item 'id #f))
(unless (exact-positive-integer? item-id)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains an invalid item id"
(architecture-concept-map-slug concept-map)))
(define linked-page (hash-ref item 'pageSlug #f))
(when (and linked-page (not (set-member? page-references linked-page)))
(error 'validate-racket-wiki-architecture!
"CMap ~a links to unknown architecture page ~a"
(architecture-concept-map-slug concept-map)
linked-page))
item-id))
(define duplicate-item-ids
(duplicate-values (map number->string item-ids)))
(unless (null? duplicate-item-ids)
(error 'validate-racket-wiki-architecture!
"CMap ~a has duplicate item ids: ~a"
(architecture-concept-map-slug concept-map)
(string-join duplicate-item-ids ", ")))
(define item-id-set (list->set item-ids))
(for ([connector (in-list connectors)])
(unless (hash? connector)
(let ((document (architecture-concept-map-document concept-map)))
(unless (hash? document)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains a non-object connector"
"CMap ~a is not a JSON object"
(architecture-concept-map-slug concept-map)))
(define source-id (hash-ref connector 'sourceId #f))
(define target-id (hash-ref connector 'targetId #f))
(unless (and (set-member? item-id-set source-id)
(set-member? item-id-set target-id))
(unless (equal? (hash-ref document 'schemaVersion #f) 1)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains a connector with an unknown endpoint"
(architecture-concept-map-slug concept-map)))))
"CMap ~a does not use schema version 1"
(architecture-concept-map-slug concept-map)))
(let ((items (hash-ref document 'items '()))
(connectors (hash-ref document 'connectors '())))
(unless (and (list? items) (list? connectors))
(error 'validate-racket-wiki-architecture!
"CMap ~a must contain item and connector arrays"
(architecture-concept-map-slug concept-map)))
(let* ((item-ids
(for/list ([item (in-list items)])
(unless (hash? item)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains a non-object item"
(architecture-concept-map-slug concept-map)))
(let ((item-id (hash-ref item 'id #f))
(linked-page (hash-ref item 'pageSlug #f)))
(unless (exact-positive-integer? item-id)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains an invalid item id"
(architecture-concept-map-slug concept-map)))
(when (and linked-page (not (set-member? page-references linked-page)))
(error 'validate-racket-wiki-architecture!
"CMap ~a links to unknown architecture page ~a"
(architecture-concept-map-slug concept-map)
linked-page))
item-id)))
(duplicate-item-ids
(duplicate-values (map number->string item-ids)))
(item-id-set (list->set item-ids)))
(unless (null? duplicate-item-ids)
(error 'validate-racket-wiki-architecture!
"CMap ~a has duplicate item ids: ~a"
(architecture-concept-map-slug concept-map)
(string-join duplicate-item-ids ", ")))
(for ([connector (in-list connectors)])
(unless (hash? connector)
(error 'validate-racket-wiki-architecture!
"CMap ~a contains a non-object connector"
(architecture-concept-map-slug concept-map)))
(let ((source-id (hash-ref connector 'sourceId #f))
(target-id (hash-ref connector 'targetId #f)))
(unless (and (set-member? item-id-set source-id)
(set-member? item-id-set target-id))
(error 'validate-racket-wiki-architecture!
"CMap ~a contains a connector with an unknown endpoint"
(architecture-concept-map-slug concept-map)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Validate every bundled page, link and CMap before importing.
@@ -207,42 +205,40 @@
; result : Two values containing the validated pages and CMaps.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (validate-racket-wiki-architecture!)
(define-values (namespace pages concept-maps)
(load-architecture-content))
(unless (string=? namespace "racket-wiki")
(error 'validate-racket-wiki-architecture!
"the architecture namespace must be racket-wiki"))
(define page-reference-list
(map architecture-page-reference pages))
(define concept-map-slug-list
(map architecture-concept-map-slug concept-maps))
(define duplicate-pages (duplicate-values page-reference-list))
(define duplicate-concept-maps (duplicate-values concept-map-slug-list))
(unless (null? duplicate-pages)
(error 'validate-racket-wiki-architecture!
"duplicate page references: ~a"
(string-join duplicate-pages ", ")))
(unless (null? duplicate-concept-maps)
(error 'validate-racket-wiki-architecture!
"duplicate CMap slugs: ~a"
(string-join duplicate-concept-maps ", ")))
(for ([reference (in-list page-reference-list)])
(unless (valid-page-reference? reference)
(let-values (((namespace pages concept-maps)
(load-architecture-content)))
(unless (string=? namespace "racket-wiki")
(error 'validate-racket-wiki-architecture!
"invalid page reference: ~a"
reference)))
(for ([slug (in-list concept-map-slug-list)])
(unless (valid-slug? slug)
(error 'validate-racket-wiki-architecture!
"invalid CMap slug: ~a"
slug)))
(define page-references (list->set page-reference-list))
(define concept-map-slugs (list->set concept-map-slug-list))
(for ([page (in-list pages)])
(validate-page-links! page page-references concept-map-slugs))
(for ([concept-map (in-list concept-maps)])
(validate-concept-map! concept-map page-references))
(values pages concept-maps))
"the architecture namespace must be racket-wiki"))
(let* ((page-reference-list (map architecture-page-reference pages))
(concept-map-slug-list (map architecture-concept-map-slug concept-maps))
(duplicate-pages (duplicate-values page-reference-list))
(duplicate-concept-maps (duplicate-values concept-map-slug-list)))
(unless (null? duplicate-pages)
(error 'validate-racket-wiki-architecture!
"duplicate page references: ~a"
(string-join duplicate-pages ", ")))
(unless (null? duplicate-concept-maps)
(error 'validate-racket-wiki-architecture!
"duplicate CMap slugs: ~a"
(string-join duplicate-concept-maps ", ")))
(for ([reference (in-list page-reference-list)])
(unless (valid-page-reference? reference)
(error 'validate-racket-wiki-architecture!
"invalid page reference: ~a"
reference)))
(for ([slug (in-list concept-map-slug-list)])
(unless (valid-slug? slug)
(error 'validate-racket-wiki-architecture!
"invalid CMap slug: ~a"
slug)))
(let ((page-references (list->set page-reference-list))
(concept-map-slugs (list->set concept-map-slug-list)))
(for ([page (in-list pages)])
(validate-page-links! page page-references concept-map-slugs))
(for ([concept-map (in-list concept-maps)])
(validate-concept-map! concept-map page-references))))
(values pages concept-maps)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Source ownership markers
@@ -256,11 +252,11 @@
markdown))
(define (page-source-unmodified? title markdown tags)
(define match (regexp-match page-source-marker-pattern markdown))
(and match
(let ([body (regexp-replace page-source-marker-pattern markdown "")]
[stored-hash (list-ref match 1)])
(string=? stored-hash (source-hash (list title body tags))))))
(let ((match (regexp-match page-source-marker-pattern markdown)))
(and match
(let ((body (regexp-replace page-source-marker-pattern markdown ""))
(stored-hash (list-ref match 1)))
(string=? stored-hash (source-hash (list title body tags)))))))
(define (concept-map-source-marker? reference)
(and (hash? reference)
@@ -268,33 +264,33 @@
concept-map-source-marker-id)))
(define (concept-map-without-source-marker document)
(define references (hash-ref document 'conceptMaps '()))
(hash-set document
'conceptMaps
(filter (λ (reference)
(not (concept-map-source-marker? reference)))
references)))
(let ((references (hash-ref document 'conceptMaps '())))
(hash-set document
'conceptMaps
(filter (λ (reference)
(not (concept-map-source-marker? reference)))
references))))
(define (concept-map-with-source-marker title document)
(define clean-document (concept-map-without-source-marker document))
(define marker
(hash 'id concept-map-source-marker-id
'kind "architecture-source"
'sourceHash (source-hash (list title clean-document))))
(hash-set clean-document
'conceptMaps
(append (hash-ref clean-document 'conceptMaps '())
(list marker))))
(let* ((clean-document (concept-map-without-source-marker document))
(marker
(hash 'id concept-map-source-marker-id
'kind "architecture-source"
'sourceHash (source-hash (list title clean-document)))))
(hash-set clean-document
'conceptMaps
(append (hash-ref clean-document 'conceptMaps '())
(list marker)))))
(define (concept-map-source-unmodified? title document)
(define marker
(findf concept-map-source-marker?
(hash-ref document 'conceptMaps '())))
(and marker
(string=? (hash-ref marker 'sourceHash "")
(source-hash
(list title
(concept-map-without-source-marker document))))))
(let ((marker
(findf concept-map-source-marker?
(hash-ref document 'conceptMaps '()))))
(and marker
(string=? (hash-ref marker 'sourceHash "")
(source-hash
(list title
(concept-map-without-source-marker document)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Import operations
@@ -312,13 +308,13 @@
(architecture-page-tags page))))
(define (import-page! config page author dry-run? overwrite-modified?)
(define reference (architecture-page-reference page))
(define marked-markdown
(page-with-source-marker (architecture-page-title page)
(architecture-page-markdown page)
(architecture-page-tags page)))
(define current (read-page config reference))
(cond
(let* ((reference (architecture-page-reference page))
(marked-markdown
(page-with-source-marker (architecture-page-title page)
(architecture-page-markdown page)
(architecture-page-tags page)))
(current (read-page config reference)))
(cond
[(not current)
(if dry-run?
(result 'page reference 'would-create "Page would be created")
@@ -355,7 +351,7 @@
(hash-ref current 'currentVersion)
"Updated racket-wiki architecture documentation"
(architecture-page-tags page))
(result 'page reference 'updated "Page updated")]))
(result 'page reference 'updated "Page updated")])))
(define (concept-map-content-equal? current concept-map marked-document)
(and (string=? (hash-ref current 'title)
@@ -364,13 +360,13 @@
marked-document)))
(define (import-concept-map! config concept-map author dry-run? overwrite-modified?)
(define slug (architecture-concept-map-slug concept-map))
(define marked-document
(concept-map-with-source-marker
(architecture-concept-map-title concept-map)
(architecture-concept-map-document concept-map)))
(define current (read-concept-map config slug))
(cond
(let* ((slug (architecture-concept-map-slug concept-map))
(marked-document
(concept-map-with-source-marker
(architecture-concept-map-title concept-map)
(architecture-concept-map-document concept-map)))
(current (read-concept-map config slug)))
(cond
[(not current)
(if dry-run?
(result 'concept-map slug 'would-create "CMap would be created")
@@ -405,7 +401,7 @@
(hash-ref current 'currentVersion)
"Updated racket-wiki architecture CMap"
"import")
(result 'concept-map slug 'updated "CMap updated")]))
(result 'concept-map slug 'updated "CMap updated")])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Import the bundled architecture set below namespace racket-wiki.
@@ -420,23 +416,23 @@
#:author [author "racket-wiki architecture import"]
#:dry-run? [dry-run? #f]
#:overwrite-modified? [overwrite-modified? #f])
(define-values (pages concept-maps)
(validate-racket-wiki-architecture!))
(ensure-wiki-data! config)
(unless (database-settings-exist? config)
(error 'import-racket-wiki-architecture!
"PostgreSQL is not configured for data directory ~a"
(wiki-config-data-dir config)))
(initialize-database! config)
(append
(for/list ([page (in-list pages)])
(import-page! config page author dry-run? overwrite-modified?))
(for/list ([concept-map (in-list concept-maps)])
(import-concept-map! config
concept-map
author
dry-run?
overwrite-modified?))))
(let-values (((pages concept-maps)
(validate-racket-wiki-architecture!)))
(ensure-wiki-data! config)
(unless (database-settings-exist? config)
(error 'import-racket-wiki-architecture!
"PostgreSQL is not configured for data directory ~a"
(wiki-config-data-dir config)))
(initialize-database! config)
(append
(for/list ([page (in-list pages)])
(import-page! config page author dry-run? overwrite-modified?))
(for/list ([concept-map (in-list concept-maps)])
(import-concept-map! config
concept-map
author
dry-run?
overwrite-modified?)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Import the architecture set using only a wiki data directory.
@@ -449,13 +445,13 @@
#:author [author "racket-wiki architecture import"]
#:dry-run? [dry-run? #f]
#:overwrite-modified? [overwrite-modified? #f])
(define config
(make-wiki-config #:data-dir data-directory))
(import-racket-wiki-architecture!
config
#:author author
#:dry-run? dry-run?
#:overwrite-modified? overwrite-modified?))
(let ((config
(make-wiki-config #:data-dir data-directory)))
(import-racket-wiki-architecture!
config
#:author author
#:dry-run? dry-run?
#:overwrite-modified? overwrite-modified?)))
(define (display-import-results results)
(for ([import-result (in-list results)])
@@ -464,17 +460,17 @@
(architecture-import-result-status import-result)
(architecture-import-result-kind import-result)
(architecture-import-result-reference import-result))))
(define skipped
(count (λ (import-result)
(eq? (architecture-import-result-status import-result)
'skipped-modified))
results))
(displayln (format "Processed ~a architecture items." (length results)))
(when (> skipped 0)
(displayln
(format
"~a locally modified item(s) were preserved. Review them before using --overwrite-modified."
skipped))))
(let ((skipped
(count (λ (import-result)
(eq? (architecture-import-result-status import-result)
'skipped-modified))
results)))
(displayln (format "Processed ~a architecture items." (length results)))
(when (> skipped 0)
(displayln
(format
"~a locally modified item(s) were preserved. Review them before using --overwrite-modified."
skipped)))))
(module+ main
(define config (default-wiki-config))
main.rkt
+9 -9
View File
@@ -30,15 +30,15 @@
#:site-title [site-title "Racket Wiki"]
#:session-seconds [session-seconds (* 12 60 60)]
#:language [language "en"])
(define config
(make-wiki-config #:data-dir data-dir
#:port port
#:listen-ip listen-ip
#:secure-cookie? secure-cookie?
#:site-title site-title
#:session-seconds session-seconds
#:language language))
(start-wiki config))
(let ((config
(make-wiki-config #:data-dir data-dir
#:port port
#:listen-ip listen-ip
#:secure-cookie? secure-cookie?
#:site-title site-title
#:session-seconds session-seconds
#:language language)))
(start-wiki config)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Start the wiki using a configuration.
migrate-cmap-subpages.rkt
+87 -87
View File
@@ -23,15 +23,15 @@
'("system:cmap-subpage-migration" "system:cmap-subpage-migration-repair"))
(define (json-list document key)
(define value (hash-ref document key '()))
(if (list? value) value '()))
(let ((value (hash-ref document key '())))
(if (list? value) value '())))
(define (parse-document text)
(define first (string->jsexpr text))
(define document (if (string? first) (string->jsexpr first) first))
(unless (hash? document)
(error 'parse-document "stored CMap document is not an object"))
document)
(let* ((first (string->jsexpr text))
(document (if (string? first) (string->jsexpr first) first)))
(unless (hash? document)
(error 'parse-document "stored CMap document is not an object"))
document))
(define (legacy-submap? item)
(and (equal? (hash-ref item 'kind "") "submap")
@@ -41,13 +41,13 @@
(and (string? slug) (string=? (string-trim slug) ""))))))
(define (submap-title item)
(define child-map (hash-ref item 'childMap ""))
(define label (hash-ref item 'label ""))
(cond ((and (string? child-map) (not (string=? (string-trim child-map) "")))
(string-trim child-map))
((and (string? label) (not (string=? (string-trim label) "")))
(string-trim label))
(else "Sub-CMap")))
(let ((child-map (hash-ref item 'childMap ""))
(label (hash-ref item 'label "")))
(cond ((and (string? child-map) (not (string=? (string-trim child-map) "")))
(string-trim child-map))
((and (string? label) (not (string=? (string-trim label) "")))
(string-trim label))
(else "Sub-CMap"))))
(define (derived-document source-slug root-id)
(hash 'schemaVersion 2
@@ -58,17 +58,17 @@
'conceptMaps '()))
(define (link-parent-document document roots)
(define slugs
(for/hash ((root (in-list roots)))
(values (hash-ref root 'id) (title->slug (submap-title root)))))
(hash-set
document
'items
(for/list ((item (in-list (json-list document 'items))))
(define slug (hash-ref slugs (hash-ref item 'id #f) #f))
(if slug
(hash-set (hash-set item 'cmapSlug slug) 'separateMap #t)
item))))
(let ((slugs
(for/hash ((root (in-list roots)))
(values (hash-ref root 'id) (title->slug (submap-title root))))))
(hash-set
document
'items
(for/list ((item (in-list (json-list document 'items))))
(let ((slug (hash-ref slugs (hash-ref item 'id #f) #f)))
(if slug
(hash-set (hash-set item 'cmapSlug slug) 'separateMap #t)
item))))))
(define (load-parent-rows connection [lock? #f])
(query-rows
@@ -98,50 +98,50 @@
(and row (member (vector-ref row 3) replaceable-authors)))
(define (check-child! connection parent-slug root [lock? #f])
(define slug (title->slug (submap-title root)))
(define row (existing-child connection slug lock?))
(when (and row (not (replaceable-child? row)))
(error 'migrate-cmap-subpages
"target CMap ~a already exists and was not created by the earlier migration"
slug))
(hash 'slug slug
'title (submap-title root)
'rootId (hash-ref root 'id)
'sourceSlug parent-slug
'existing row))
(let* ((slug (title->slug (submap-title root)))
(row (existing-child connection slug lock?)))
(when (and row (not (replaceable-child? row)))
(error 'migrate-cmap-subpages
"target CMap ~a already exists and was not created by the earlier migration"
slug))
(hash 'slug slug
'title (submap-title root)
'rootId (hash-ref root 'id)
'sourceSlug parent-slug
'existing row)))
(define (plans-for-row connection row [lock? #f])
(define document (parse-document (vector-ref row 3)))
(define roots (filter legacy-submap? (json-list document 'items)))
(define children
(for/list ((root (in-list roots)))
(check-child! connection (vector-ref row 1) root lock?)))
(values children (link-parent-document document roots)))
(let* ((document (parse-document (vector-ref row 3)))
(roots (filter legacy-submap? (json-list document 'items)))
(children
(for/list ((root (in-list roots)))
(check-child! connection (vector-ref row 1) root lock?))))
(values children (link-parent-document document roots))))
(define (report-plan connection)
(define total 0)
(for ((row (in-list (load-parent-rows connection))))
(define-values (children ignored-parent) (plans-for-row connection row))
(printf "Parent ~a (~a): ~a shared submap view(s)\n"
(vector-ref row 1) (vector-ref row 2) (length children))
(for ((child (in-list children)))
(set! total (add1 total))
(printf " ~a -> ~a (~a)\n"
(hash-ref child 'title)
(hash-ref child 'slug)
(if (hash-ref child 'existing) "replace earlier migration result" "create"))))
(printf "Total: ~a shared view(s). No data changed.\n" total)
total)
(let ((total 0))
(for ((row (in-list (load-parent-rows connection))))
(let-values (((children ignored-parent) (plans-for-row connection row)))
(printf "Parent ~a (~a): ~a shared submap view(s)\n"
(vector-ref row 1) (vector-ref row 2) (length children))
(for ((child (in-list children)))
(set! total (add1 total))
(printf " ~a -> ~a (~a)\n"
(hash-ref child 'title)
(hash-ref child 'slug)
(if (hash-ref child 'existing) "replace earlier migration result" "create")))))
(printf "Total: ~a shared view(s). No data changed.\n" total)
total))
(define (write-child! connection child now)
(define document-text
(jsexpr->string
(derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId))))
(define existing (hash-ref child 'existing))
(if existing
(let* ((map-id (vector-ref existing 0))
(title (vector-ref existing 1))
(next-version (add1 (vector-ref existing 2))))
(let ((document-text
(jsexpr->string
(derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId))))
(existing (hash-ref child 'existing)))
(if existing
(let* ((map-id (vector-ref existing 0))
(title (vector-ref existing 1))
(next-version (add1 (vector-ref existing 2))))
(query-exec
connection
#<<SQL
@@ -178,42 +178,42 @@ INSERT INTO concept_map_versions
VALUES ($1,1,$2,$3::text::jsonb,$4,'shared-view-migration',
'Created canonical shared sub-CMap view',$5)
SQL
map-id (hash-ref child 'title) document-text migration-author now))))
map-id (hash-ref child 'title) document-text migration-author now)))))
(define (apply-migration! connection)
(call-with-transaction
connection
(lambda ()
(define now (current-seconds))
(define total 0)
(for ((row (in-list (load-parent-rows connection #t))))
(define-values (children parent-document) (plans-for-row connection row #t))
(for ((child (in-list children)))
(write-child! connection child now)
(set! total (add1 total)))
(unless (null? children)
(define map-id (vector-ref row 0))
(define next-version (add1 (vector-ref row 4)))
(define parent-text (jsexpr->string parent-document))
(query-exec
connection
#<<SQL
(λ ()
(let ((now (current-seconds))
(total 0))
(for ((row (in-list (load-parent-rows connection #t))))
(let-values (((children parent-document) (plans-for-row connection row #t)))
(for ((child (in-list children)))
(write-child! connection child now)
(set! total (add1 total)))
(unless (null? children)
(let ((map-id (vector-ref row 0))
(next-version (add1 (vector-ref row 4)))
(parent-text (jsexpr->string parent-document)))
(query-exec
connection
#<<SQL
UPDATE concept_maps
SET document=$1::text::jsonb, current_version=$2, updated_at=$3, updated_by=$4
WHERE id=$5
SQL
parent-text next-version now migration-author map-id)
(query-exec
connection
#<<SQL
parent-text next-version now migration-author map-id)
(query-exec
connection
#<<SQL
INSERT INTO concept_map_versions
(concept_map_id,version,title,document,author,action,summary,created_at)
VALUES ($1,$2,$3,$4::text::jsonb,$5,'shared-view-migration',
'Linked internal sub-CMaps to standalone shared views without moving graph data',$6)
SQL
map-id next-version (vector-ref row 2) parent-text migration-author now)))
(printf "Migrated ~a submap(s) to shared stored views in one transaction.\n" total)
total)))
map-id next-version (vector-ref row 2) parent-text migration-author now)))))
(printf "Migrated ~a submap(s) to shared stored views in one transaction.\n" total)
total))))
(module+ main
(define config (default-wiki-config))
@@ -231,5 +231,5 @@ SQL
(set! apply? #t)))
(call-with-wiki-database
config
(lambda (connection)
(λ (connection)
(if apply? (apply-migration! connection) (report-plan connection)))))
private/attachment-references.rkt
+36 -36
View File
@@ -28,49 +28,49 @@ SQL
(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)
(let* ((current
(query-row db
"SELECT namespace, slug FROM pages WHERE id = $1"
page-id))
(references
(list (if (string=? (vector-ref current 0) "")
(vector-ref current 1)
(string-append (vector-ref current 0) ":" (vector-ref current 1)))))
(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))))
(let ((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 owner-page-id (vector-ref row 1))
(define stored-name (vector-ref row 2))
(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
(let ((attachment-id (vector-ref row 0))
(owner-page-id (vector-ref row 1))
(stored-name (vector-ref row 2))
(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
(attachment_id, page_id, page_version_id, current_reference, referenced_at)
VALUES ($1, $2, $3, $4, $5)
SQL
attachment-id
page-id
page-version-id
current?
referenced-at))))
attachment-id
page-id
page-version-id
current?
referenced-at)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
private/auth.rkt
+187 -181
View File
@@ -56,10 +56,10 @@
(define (bytes->hex value)
(apply string-append
(for/list ([byte (in-bytes value)])
(define hex (number->string byte 16))
(if (= (string-length hex) 1)
(string-append "0" hex)
hex))))
(let ((hex (number->string byte 16)))
(if (= (string-length hex) 1)
(string-append "0" hex)
hex)))))
(define (random-token [size 32])
(bytes->hex (crypto-random-bytes size)))
@@ -88,8 +88,8 @@
(if (sql-null? value) #f value))
(define (normalized-email email)
(define value (string-downcase (string-trim (or email ""))))
(if (string=? value "") sql-null value))
(let ((value (string-downcase (string-trim (or email "")))))
(if (string=? value "") sql-null value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Authenticate an enabled wiki user.
@@ -101,22 +101,22 @@
(call-with-wiki-database
config
(λ (db)
(define row
(query-maybe-row
db
"SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1"
username))
(cond
((not row) #f)
((not (vector-ref row 5)) #f)
((not (password-valid? password (vector-ref row 6))) #f)
(else
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
#t))))))
(let ((row
(query-maybe-row
db
"SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1"
username)))
(cond
((not row) #f)
((not (vector-ref row 5)) #f)
((not (password-valid? password (vector-ref row 6))) #f)
(else
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
#t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a login session for a user.
@@ -125,21 +125,21 @@
; result : A wiki-session containing the client session token.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-session! config user)
(define token (random-token))
(define csrf-token (random-token 24))
(define now (current-seconds))
(define expires-at (+ now (wiki-config-session-seconds config)))
(call-with-wiki-database
config
(λ (db)
(query-exec db
"INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)"
(token-hash token)
(wiki-user-id user)
csrf-token
now
expires-at)))
(wiki-session user csrf-token expires-at token))
(let* ((token (random-token))
(csrf-token (random-token 24))
(now (current-seconds))
(expires-at (+ now (wiki-config-session-seconds config))))
(call-with-wiki-database
config
(λ (db)
(query-exec db
"INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)"
(token-hash token)
(wiki-user-id user)
csrf-token
now
expires-at)))
(wiki-session user csrf-token expires-at token)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Delete a login session.
@@ -157,13 +157,13 @@
(token-hash token))))))
(define (session-cookie-token req)
(define cookie
(findf (λ (candidate)
(string=? (client-cookie-name candidate) "racket-wiki-session"))
(request-cookies req)))
(if cookie
(client-cookie-value cookie)
#f))
(let ((cookie
(findf (λ (candidate)
(string=? (client-cookie-name candidate) "racket-wiki-session"))
(request-cookies req))))
(if cookie
(client-cookie-value cookie)
#f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve an authenticated session from a request cookie.
@@ -172,36 +172,36 @@
; result : A non-expired wiki-session for an enabled user, or #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (session-from-request config req)
(define token (session-cookie-token req))
(if token
(call-with-wiki-database
config
(λ (db)
(define row
(query-maybe-row
db
#<<SQL
(let ((token (session-cookie-token req)))
(if token
(call-with-wiki-database
config
(λ (db)
(let ((row
(query-maybe-row
db
#<<SQL
SELECT u.id, u.username, u.display_name, u.email, u.role, u.enabled,
s.csrf_token, s.expires_at
FROM sessions s
JOIN users u ON u.id = s.user_id
WHERE s.token_hash = $1 AND s.expires_at > $2 AND u.enabled = TRUE
SQL
(token-hash token)
(current-seconds)))
(if row
(wiki-session
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
(vector-ref row 5))
(vector-ref row 6)
(vector-ref row 7)
token)
#f)))
#f))
(token-hash token)
(current-seconds))))
(if row
(wiki-session
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
(vector-ref row 5))
(vector-ref row 6)
(vector-ref row 7)
token)
#f))))
#f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Validate a CSRF token for a session.
@@ -249,23 +249,23 @@ SQL
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-user! config username display-name password role status [email #f])
(define now (current-seconds))
(define enabled (eq? status 'enabled))
(define hash (password-hash password))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
"INSERT INTO users(username, display_name, email, password_hash, role, enabled, created_at, updated_at) VALUES ($1, $2, $3, $4, $5, $6, $7, $8)"
username
display-name
(normalized-email email)
hash
(symbol->string role)
enabled
now
now))))
(let ((now (current-seconds))
(enabled (eq? status 'enabled))
(hash (password-hash password)))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
"INSERT INTO users(username, display_name, email, password_hash, role, enabled, created_at, updated_at) VALUES ($1, $2, $3, $4, $5, $6, $7, $8)"
username
display-name
(normalized-email email)
hash
(symbol->string role)
enabled
now
now)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create or reset a wiki user by username.
@@ -274,15 +274,15 @@ SQL
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (upsert-user! config username display-name password role status)
(define now (current-seconds))
(define enabled (eq? status 'enabled))
(define hash (password-hash password))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
#<<SQL
(let ((now (current-seconds))
(enabled (eq? status 'enabled))
(hash (password-hash password)))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
#<<SQL
INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at)
VALUES ($1, $2, $3, $4, $5, $6, $7)
ON CONFLICT(username) DO UPDATE SET
@@ -292,7 +292,7 @@ ON CONFLICT(username) DO UPDATE SET
enabled = excluded.enabled,
updated_at = excluded.updated_at
SQL
username display-name hash (symbol->string role) enabled now now))))
username display-name hash (symbol->string role) enabled now now)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Update a wiki user.
@@ -301,29 +301,29 @@ SQL
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-user! config id display-name role status [password #f] [email #f])
(define enabled (eq? status 'enabled))
(define now (current-seconds))
(call-with-wiki-database
config
(λ (db)
(if (and password (not (string=? password "")))
(query-exec db
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, password_hash = $5, updated_at = $6 WHERE id = $7"
display-name
(normalized-email email)
(symbol->string role)
enabled
(password-hash password)
now
id)
(query-exec db
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, updated_at = $5 WHERE id = $6"
display-name
(normalized-email email)
(symbol->string role)
enabled
now
id)))))
(let ((enabled (eq? status 'enabled))
(now (current-seconds)))
(call-with-wiki-database
config
(λ (db)
(if (and password (not (string=? password "")))
(query-exec db
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, password_hash = $5, updated_at = $6 WHERE id = $7"
display-name
(normalized-email email)
(symbol->string role)
enabled
(password-hash password)
now
id)
(query-exec db
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, updated_at = $5 WHERE id = $6"
display-name
(normalized-email email)
(symbol->string role)
enabled
now
id))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Update the authenticated user's profile and optionally password.
@@ -332,31 +332,31 @@ SQL
; result : void; an invalid current password raises an exception.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-own-profile! config user-id session-token display-name email current-password new-password)
(define change-password?
(and new-password (not (string=? new-password ""))))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(when change-password?
(define stored-hash
(query-maybe-value db "SELECT password_hash FROM users WHERE id = $1" user-id))
(unless (and stored-hash current-password (password-valid? current-password stored-hash))
(error 'update-own-profile! "The current password is incorrect")))
(if change-password?
(let ((change-password?
(and new-password (not (string=? new-password "")))))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(when change-password?
(let ((stored-hash
(query-maybe-value db "SELECT password_hash FROM users WHERE id = $1" user-id)))
(unless (and stored-hash current-password (password-valid? current-password stored-hash))
(error 'update-own-profile! "The current password is incorrect"))))
(if change-password?
(query-exec db
"UPDATE users SET display_name = $1, email = $2, password_hash = $3, updated_at = $4 WHERE id = $5"
display-name (normalized-email email) (password-hash new-password) (current-seconds) user-id)
(query-exec db
"UPDATE users SET display_name = $1, email = $2, updated_at = $3 WHERE id = $4"
display-name (normalized-email email) (current-seconds) user-id))
(when change-password?
(query-exec db
"UPDATE users SET display_name = $1, email = $2, password_hash = $3, updated_at = $4 WHERE id = $5"
display-name (normalized-email email) (password-hash new-password) (current-seconds) user-id)
(query-exec db
"UPDATE users SET display_name = $1, email = $2, updated_at = $3 WHERE id = $4"
display-name (normalized-email email) (current-seconds) user-id))
(when change-password?
(query-exec db
"DELETE FROM sessions WHERE user_id = $1 AND token_hash <> $2"
user-id
(token-hash session-token))))))))
"DELETE FROM sessions WHERE user_id = $1 AND token_hash <> $2"
user-id
(token-hash session-token)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a short-lived one-time password-reset token for an account.
@@ -365,34 +365,40 @@ SQL
; result : A pair containing raw token and email, or #f when no account matches.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-password-reset! config identity [lifetime 3600] [maximum-per-hour 2])
(define token (random-token))
(define now (current-seconds))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(query-exec db "DELETE FROM password_reset_tokens WHERE created_at <= $1" (- now 3600))
(define row
(query-maybe-row db
"SELECT id, email FROM users WHERE enabled = TRUE AND (lower(username) = lower($1) OR lower(email) = lower($1)) FOR UPDATE"
(string-trim identity)))
(if (and row (not (sql-null? (vector-ref row 1))))
(let ((recent-count
(query-value db
"SELECT COUNT(*) FROM password_reset_tokens WHERE user_id = $1 AND created_at > $2"
(vector-ref row 0)
(- now 3600))))
(if (>= recent-count maximum-per-hour)
#f
(begin
(query-exec db
"INSERT INTO password_reset_tokens(token_hash, user_id, created_at, expires_at) VALUES ($1, $2, $3, $4)"
(token-hash token) (vector-ref row 0) now (+ now lifetime))
(cons token (vector-ref row 1)))))
#f))))))
(let ((token (random-token))
(now (current-seconds)))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(query-exec db "DELETE FROM password_reset_tokens WHERE created_at <= $1" (- now 3600))
(let ((row
(query-maybe-row db
"SELECT id, email FROM users WHERE enabled = TRUE AND (lower(username) = lower($1) OR lower(email) = lower($1)) FOR UPDATE"
(string-trim identity))))
(if (and row (not (sql-null? (vector-ref row 1))))
(let ((recent-count
(query-value db
"SELECT COUNT(*) FROM password_reset_tokens WHERE user_id = $1 AND created_at > $2"
(vector-ref row 0)
(- now 3600))))
(if (>= recent-count maximum-per-hour)
#f
(begin
(query-exec db
"INSERT INTO password_reset_tokens(token_hash, user_id, created_at, expires_at) VALUES ($1, $2, $3, $4)"
(token-hash token) (vector-ref row 0) now (+ now lifetime))
(cons token (vector-ref row 1)))))
#f))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Invalidate one pending password-reset token.
; pre : token is the raw token supplied to the password-reset workflow.
; post : The matching reset-token row, when present, has been deleted.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cancel-password-reset! config token)
(call-with-wiki-database
config
@@ -412,18 +418,18 @@ SQL
(call-with-transaction
db
(λ ()
(define now (current-seconds))
(define user-id
(query-maybe-value db
"SELECT user_id FROM password_reset_tokens WHERE token_hash = $1 AND used_at IS NULL AND expires_at > $2 FOR UPDATE"
(token-hash token) now))
(if user-id
(begin
(query-exec db "UPDATE users SET password_hash = $1, updated_at = $2 WHERE id = $3" (password-hash password) now user-id)
(query-exec db "UPDATE password_reset_tokens SET used_at = $1 WHERE user_id = $2 AND used_at IS NULL" now user-id)
(query-exec db "DELETE FROM sessions WHERE user_id = $1" user-id)
#t)
#f))))))
(let* ((now (current-seconds))
(user-id
(query-maybe-value db
"SELECT user_id FROM password_reset_tokens WHERE token_hash = $1 AND used_at IS NULL AND expires_at > $2 FOR UPDATE"
(token-hash token) now)))
(if user-id
(begin
(query-exec db "UPDATE users SET password_hash = $1, updated_at = $2 WHERE id = $3" (password-hash password) now user-id)
(query-exec db "UPDATE password_reset_tokens SET used_at = $1 WHERE user_id = $2 AND used_at IS NULL" now user-id)
(query-exec db "DELETE FROM sessions WHERE user_id = $1" user-id)
#t)
#f)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Delete a wiki user.
private/cmap-storage.rkt
+3 -3
View File
@@ -830,7 +830,7 @@ SQL
(and version-number
(call-with-wiki-database
config
(lambda (db)
(λ (db)
(and
(query-maybe-value
db
@@ -962,13 +962,13 @@ SQL
'externalUrl)
"https://example.com/path")
(check-exn exn:fail?
(lambda ()
(λ ()
(concept-content
(hash 'id concept-a
'label "Unsafe concept"
'externalUrl "javascript:alert(1)"))))
(check-exn exn:fail?
(lambda ()
(λ ()
(concept-map-storage-document
(hash 'concepts (list (hash 'id "legacy:map:concept-1"))
'items '())))))
private/cmap-styles.rkt
+72 -49
View File
@@ -97,59 +97,82 @@
(define (normalize-cmap-styles styles [who 'cmap-styles])
(unless (and (list? styles) (<= 1 (length styles) maximum-style-count))
(error who "styles must contain between 1 and ~a entries" maximum-style-count))
(define seen (make-hash))
(define normalized
(for/list ([style (in-list styles)])
(unless (hash? style) (error who "each style must be an object"))
(define id (required-string who (hash-ref style 'id #f) "style id" 120))
(unless (regexp-match? #px"^[A-Za-z0-9_-]+$" id) (error who "invalid style id"))
(when (hash-ref seen id #f) (error who "duplicate style id: ~a" id))
(hash-set! seen id #t)
(define name (and (string? (hash-ref style 'name #f))
(required-string who (hash-ref style 'name) "style name" maximum-style-name-length)))
(define name-key (and (string? (hash-ref style 'nameKey #f))
(string->symbol (required-string who (hash-ref style 'nameKey) "style name key" 40))))
(unless (or name (member name-key permitted-name-keys))
(error who "a style needs a name"))
(hash 'id id
(if (member name-key permitted-name-keys) 'nameKey 'name)
(if (member name-key permitted-name-keys) (symbol->string name-key) name)
'protected (string=? id "default")
'values (normalize-style-values who (hash-ref style 'values #f)))))
(unless (hash-ref seen "default" #f) (error who "the default style is required"))
normalized)
(let* ((seen (make-hash))
(normalized
(for/list ([style (in-list styles)])
(unless (hash? style) (error who "each style must be an object"))
(let* ((id (required-string who (hash-ref style 'id #f) "style id" 120))
(name (and (string? (hash-ref style 'name #f))
(required-string who
(hash-ref style 'name)
"style name"
maximum-style-name-length)))
(name-key
(and (string? (hash-ref style 'nameKey #f))
(string->symbol
(required-string who
(hash-ref style 'nameKey)
"style name key"
40)))))
(unless (regexp-match? #px"^[A-Za-z0-9_-]+$" id)
(error who "invalid style id"))
(when (hash-ref seen id #f)
(error who "duplicate style id: ~a" id))
(hash-set! seen id #t)
(unless (or name (member name-key permitted-name-keys))
(error who "a style needs a name"))
(hash 'id id
(if (member name-key permitted-name-keys) 'nameKey 'name)
(if (member name-key permitted-name-keys) (symbol->string name-key) name)
'protected (string=? id "default")
'values (normalize-style-values who (hash-ref style 'values #f)))))))
(unless (hash-ref seen "default" #f)
(error who "the default style is required"))
normalized))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the shared CMap appearance styles.
; pre : The wiki database is configured and its schema is initialized.
; post : Default styles are inserted when no style setting exists yet.
; result : A validated, normalized non-empty list of style hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-cmap-styles config)
(call-with-wiki-database
config
(lambda (db)
(define stored
(query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
(if stored
(normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles)
(let ([encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))])
(query-exec
db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING"
setting-key encoded (current-seconds))
(normalize-cmap-styles
(string->jsexpr
(query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
'read-cmap-styles))))))
(λ (db)
(let ((stored
(query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key)))
(if stored
(normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles)
(let ((encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))))
(query-exec
db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING"
setting-key encoded (current-seconds))
(normalize-cmap-styles
(string->jsexpr
(query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
'read-cmap-styles)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Validate and store the shared CMap appearance styles.
; pre : styles is a non-empty list containing the required default style.
; post : The normalized style setting is stored atomically in the database.
; result : The normalized list of stored style hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (save-cmap-styles! config styles)
(define normalized (normalize-cmap-styles styles 'save-cmap-styles!))
(define encoded (jsexpr->string normalized))
(when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024))
(error 'save-cmap-styles! "style data is too large"))
(call-with-wiki-database
config
(lambda (db)
(query-exec
db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
setting-key encoded (current-seconds))))
normalized)
(let* ((normalized (normalize-cmap-styles styles 'save-cmap-styles!))
(encoded (jsexpr->string normalized)))
(when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024))
(error 'save-cmap-styles! "style data is too large"))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
setting-key encoded (current-seconds))))
normalized))
(module+ test
(require rackunit)
@@ -164,8 +187,8 @@
(list (hash 'id "default" 'nameKey "style-default" 'values values))))
(check-equal? (hash-ref (hash-ref (first normalized) 'values) 'backgroundColor) "#fff4cf")
(check-equal? (length (normalize-cmap-styles initial-cmap-styles)) 5)
(check-exn exn:fail? (lambda () (normalize-cmap-styles '())))
(check-exn exn:fail? (λ () (normalize-cmap-styles '())))
(check-exn exn:fail?
(lambda ()
(λ ()
(normalize-cmap-styles
(list (hash 'id "custom" 'name "Custom" 'values values))))))
private/concept-id.rkt
+25 -1
View File
@@ -17,20 +17,44 @@
;; Concept ids are stored as plain UUID strings. Validation accepts uppercase
;; input, while normalization always produces the canonical lowercase form.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether a value is a plain UUID concept identifier.
; pre : value is any Racket value.
; post : No state is changed.
; result : #t when value is a UUID string, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (concept-id? value)
(uuid-string? value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Convert a supported concept identifier to its canonical form.
; pre : value is any Racket value.
; post : No state is changed.
; result : A lowercase UUID string, or #f when value is not recognized.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (normalize-concept-id value)
(cond
[(uuid-string? value) (string-downcase value)]
[(and (string? value)
(regexp-match prefixed-uuid-concept-id-pattern value))
=> (lambda (match) (string-downcase (cadr match)))]
=> (λ (match) (string-downcase (cadr match)))]
[else #f]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a new canonical concept identifier.
; pre : none.
; post : No persistent state is changed.
; result : A freshly generated lowercase UUID string.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (new-concept-id)
(uuid-string))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Normalize a concept identifier or create a replacement.
; pre : value is any Racket value.
; post : No persistent state is changed.
; result : The normalized identifier, or a fresh UUID when value is invalid.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (normalized-or-new-concept-id value)
(or (normalize-concept-id value)
(new-concept-id)))
private/config.rkt
+53 -11
View File
@@ -43,35 +43,77 @@
#:site-title [site-title "Racket Wiki"]
#:session-seconds [session-seconds (* 12 60 60)]
#:language [language "en"])
(define normalized-listen-ip
(if (equal? listen-ip "*")
#f
listen-ip))
(wiki-config (path->complete-path data-dir)
port
normalized-listen-ip
secure-cookie?
site-title
session-seconds
language))
(let ((normalized-listen-ip
(if (equal? listen-ip "*")
#f
listen-ip)))
(wiki-config (path->complete-path data-dir)
port
normalized-listen-ip
secure-cookie?
site-title
session-seconds
language)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create the default wiki configuration.
; pre : none.
; post : No files or settings have been changed.
; result : A wiki-config using the documented default values.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (default-wiki-config)
(make-wiki-config))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the directory containing uploaded files.
; pre : config is a wiki-config value.
; post : No directory is created.
; result : The uploads path below the configured data directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (uploads-directory config)
(build-path (wiki-config-data-dir config) "uploads"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the directory reserved for deleted data.
; pre : config is a wiki-config value.
; post : No directory is created.
; result : The deleted-data path below the configured data directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (deleted-directory config)
(build-path (wiki-config-data-dir config) "deleted"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the writable static-data directory.
; pre : config is a wiki-config value.
; post : No directory is created.
; result : The static path below the configured data directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (data-static-directory config)
(build-path (wiki-config-data-dir config) "static"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the downloaded browser-library directory.
; pre : config is a wiki-config value.
; post : No directory is created.
; result : The vendor path below the writable static-data directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (vendor-directory config)
(build-path (data-static-directory config) "vendor"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the PostgreSQL settings file.
; pre : config is a wiki-config value.
; post : No file is created or read.
; result : The database.rktd path below the configured data directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (database-config-path config)
(build-path (wiki-config-data-dir config) "database.rktd"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the selected-language settings file.
; pre : config is a wiki-config value.
; post : No file is created or read.
; result : The language.rktd path below the configured data directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (language-config-path config)
(build-path (wiki-config-data-dir config) "language.rktd"))
private/database.rkt
+65 -29
View File
@@ -26,6 +26,12 @@
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether PostgreSQL settings have been saved.
; pre : config is a wiki-config value.
; post : The settings path has only been inspected.
; result : #t when database.rktd exists, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (database-settings-exist? config)
(file-exists? (database-config-path config)))
@@ -45,12 +51,24 @@
(hash-ref value 'password "")
(hash-ref value 'ssl 'no)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the saved PostgreSQL connection settings.
; pre : config is a wiki-config value.
; post : The settings file, when present, has only been read.
; result : A database-settings value, or #f when no settings file exists.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-database-settings config)
(and (database-settings-exist? config)
(call-with-input-file (database-config-path config)
(λ (in)
(datum->settings (read in))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Persist PostgreSQL connection settings.
; pre : config and settings are wiki-config and database-settings values.
; post : database.rktd contains settings and is private where supported.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (write-database-settings! config settings)
(make-directory* (wiki-config-data-dir config))
(call-with-output-file (database-config-path config)
@@ -63,24 +81,30 @@
(void))
(define (connect settings)
(define password
(if (string=? (database-settings-password settings) "")
#f
(database-settings-password settings)))
(postgresql-connect #:server (database-settings-server settings)
#:port (database-settings-port settings)
#:database (database-settings-database settings)
#:user (database-settings-user settings)
#:password password
#:ssl (database-settings-ssl settings)))
(let ((password
(if (string=? (database-settings-password settings) "")
#f
(database-settings-password settings))))
(postgresql-connect #:server (database-settings-server settings)
#:port (database-settings-port settings)
#:database (database-settings-database settings)
#:user (database-settings-user settings)
#:password password
#:ssl (database-settings-ssl settings))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Verify that supplied PostgreSQL settings can execute a query.
; pre : settings is a database-settings value for a reachable database.
; post : The temporary connection is closed on success or failure.
; result : void, or a database exception when validation fails.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-database-settings! settings)
(define db (connect settings))
(dynamic-wind
void
(λ () (query-value db "SELECT 1"))
(λ () (disconnect db)))
(void))
(let ((db (connect settings)))
(dynamic-wind
void
(λ () (query-value db "SELECT 1"))
(λ () (disconnect db)))
(void)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Run a procedure with a fresh PostgreSQL connection.
@@ -89,26 +113,32 @@
; result : The value returned by proc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (call-with-wiki-database config proc)
(define settings (read-database-settings config))
(unless settings
(error 'call-with-wiki-database "PostgreSQL is not configured"))
(define db (connect settings))
(dynamic-wind
void
(λ () (proc db))
(λ () (disconnect db))))
(let ((settings (read-database-settings config)))
(unless settings
(error 'call-with-wiki-database "PostgreSQL is not configured"))
(let ((db (connect settings)))
(dynamic-wind
void
(λ () (proc db))
(λ () (disconnect db))))))
(define (initialize-on-connection! db config)
(migrate-database! db config)
(query-exec db "DELETE FROM sessions WHERE expires_at <= $1" (current-seconds))
(void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Initialize the wiki schema using explicit PostgreSQL settings.
; pre : settings can connect to a writable PostgreSQL database.
; post : Migrations are complete, expired sessions are removed and the connection is closed.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (initialize-database-with-settings! settings config)
(define db (connect settings))
(dynamic-wind
void
(λ () (initialize-on-connection! db config))
(λ () (disconnect db))))
(let ((db (connect settings)))
(dynamic-wind
void
(λ () (initialize-on-connection! db config))
(λ () (disconnect db)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Initialize the PostgreSQL schema used by racket-wiki.
@@ -122,6 +152,12 @@
(λ (db)
(initialize-on-connection! db config))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether the configured database has the required core tables.
; pre : config is a wiki-config value.
; post : The database is unchanged and every temporary connection is closed.
; result : #t when settings and core tables are available, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (database-ready? config)
(and (database-settings-exist? config)
(with-handlers ((exn:fail? (λ (_e) #f)))
private/http-util.rkt
+18 -18
View File
@@ -82,10 +82,10 @@
; result : The decoded JSON value, or an empty hash for an empty body.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-json req)
(define body (request-post-data/raw req))
(if body
(bytes->jsexpr body)
(hash)))
(let ((body (request-post-data/raw req)))
(if body
(bytes->jsexpr body)
(hash))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read a request header as UTF-8 text.
@@ -94,11 +94,11 @@
; result : The header value as a string, or #f when absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-header/string req name)
(define found
(headers-assq* (string->bytes/utf-8 name)
(request-headers/raw req)))
(and found
(bytes->string/utf-8 (header-value found))))
(let ((found
(headers-assq* (string->bytes/utf-8 name)
(request-headers/raw req))))
(and found
(bytes->string/utf-8 (header-value found)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create an HTTP response containing bytes.
@@ -121,12 +121,12 @@
; result : A MIME byte string; application/octet-stream when the extension is unknown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (extension->mime filename)
(define lower (string-downcase filename))
(cond
((regexp-match? #px"[.]png$" lower) #"image/png")
((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg")
((regexp-match? #px"[.]gif$" lower) #"image/gif")
((regexp-match? #px"[.]webp$" lower) #"image/webp")
((regexp-match? #px"[.]pdf$" lower) #"application/pdf")
((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8")
(else #"application/octet-stream")))
(let ((lower (string-downcase filename)))
(cond
((regexp-match? #px"[.]png$" lower) #"image/png")
((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg")
((regexp-match? #px"[.]gif$" lower) #"image/gif")
((regexp-match? #px"[.]webp$" lower) #"image/webp")
((regexp-match? #px"[.]pdf$" lower) #"application/pdf")
((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8")
(else #"application/octet-stream"))))
private/mail.rkt
+155 -140
View File
@@ -18,10 +18,10 @@
send-password-reset-mail!)
(define (environment-value name)
(define value (getenv name))
(and value
(not (string=? (string-trim value) ""))
(string-trim value)))
(let ((value (getenv name)))
(and value
(not (string=? (string-trim value) ""))
(string-trim value))))
(define (safe-header-value value)
(regexp-replace* #px"[\r\n]+" value " "))
@@ -33,26 +33,26 @@
; result : An encoder accepted by smtp-send-message.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-starttls-encoder host accept-untrusted-certificates?)
(define context
(if accept-untrusted-certificates?
(ssl-make-client-context 'auto)
(ssl-secure-client-context)))
(λ (input-port output-port
#:mode mode
#:encrypt _protocol
#:close-original? close-original?)
(if accept-untrusted-certificates?
(ports->ssl-ports input-port
output-port
#:mode mode
#:context context
#:close-original? close-original?)
(ports->ssl-ports input-port
output-port
#:mode mode
#:context context
#:hostname host
#:close-original? close-original?))))
(let ((context
(if accept-untrusted-certificates?
(ssl-make-client-context 'auto)
(ssl-secure-client-context))))
(λ (input-port output-port
#:mode mode
#:encrypt _protocol
#:close-original? close-original?)
(if accept-untrusted-certificates?
(ports->ssl-ports input-port
output-port
#:mode mode
#:context context
#:close-original? close-original?)
(ports->ssl-ports input-port
output-port
#:mode mode
#:context context
#:hostname host
#:close-original? close-original?)))))
(define setting-environment-names
(hash "public-url" "RACKET_WIKI_PUBLIC_URL"
@@ -72,20 +72,32 @@
(for/hash ((row (in-list (query-rows db "SELECT key, value FROM wiki_settings WHERE key LIKE 'mail.%'"))))
(values (substring (vector-ref row 0) 5) (vector-ref row 1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the effective password-reset mail settings.
; pre : The wiki database schema is initialized.
; post : Database settings and environment variables have only been read.
; result : A hash containing every supported mail setting and its effective value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (password-reset-mail-settings config)
(define stored (database-mail-settings config))
(for/hash (((key environment-name) (in-hash setting-environment-names)))
(define default
(cond
((string=? key "smtp-port") "587")
((string=? key "reset-limit") "2")
((string=? key "smtp-tls") "true")
((string=? key "smtp-accept-untrusted-certificates") "false")
(else "")))
(values key (or (hash-ref stored key #f)
(environment-value environment-name)
default))))
(let ((stored (database-mail-settings config)))
(for/hash (((key environment-name) (in-hash setting-environment-names)))
(let ((default
(cond
((string=? key "smtp-port") "587")
((string=? key "reset-limit") "2")
((string=? key "smtp-tls") "true")
((string=? key "smtp-accept-untrusted-certificates") "false")
(else ""))))
(values key (or (hash-ref stored key #f)
(environment-value environment-name)
default))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Store password-reset mail settings supplied by an administrator.
; pre : settings is a hash containing string values for supported mail keys.
; post : Non-empty settings are upserted and cleared settings are removed atomically.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (save-password-reset-mail-settings! config settings)
(call-with-wiki-database
config
@@ -94,88 +106,91 @@
db
(λ ()
(for (((key _environment-name) (in-hash setting-environment-names)))
(define supplied-value (hash-ref settings key ""))
(define value
(if (string=? key "smtp-password")
supplied-value
(string-trim supplied-value)))
(unless (and (string=? key "smtp-password") (string=? value ""))
(if (string=? value "")
(query-exec db "DELETE FROM wiki_settings WHERE key = $1" (string-append "mail." key))
(query-exec db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
(string-append "mail." key) value (current-seconds))))))))))
(let* ((supplied-value (hash-ref settings key ""))
(value
(if (string=? key "smtp-password")
supplied-value
(string-trim supplied-value))))
(unless (and (string=? key "smtp-password") (string=? value ""))
(if (string=? value "")
(query-exec db "DELETE FROM wiki_settings WHERE key = $1" (string-append "mail." key))
(query-exec db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
(string-append "mail." key) value (current-seconds)))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether password-reset email has its minimum required settings.
; pre : The wiki database schema is initialized.
; post : Mail settings have only been read.
; result : #t when public URL, SMTP host and sender are non-empty, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (password-reset-mail-configured? config)
(define settings (password-reset-mail-settings config))
(and (not (string=? (hash-ref settings "public-url") ""))
(not (string=? (hash-ref settings "smtp-host") ""))
(not (string=? (hash-ref settings "smtp-from") ""))))
(let ((settings (password-reset-mail-settings config)))
(and (not (string=? (hash-ref settings "public-url") ""))
(not (string=? (hash-ref settings "smtp-host") ""))
(not (string=? (hash-ref settings "smtp-from") "")))))
(define (settings-with-stored-password config supplied-settings)
(define stored-settings (password-reset-mail-settings config))
(define supplied-password (hash-ref supplied-settings "smtp-password" ""))
(define effective-password
(if (string=? supplied-password "")
(hash-ref stored-settings "smtp-password" "")
supplied-password))
(for/hash (((key _environment-name) (in-hash setting-environment-names)))
(define value
(if (string=? key "smtp-password")
effective-password
(hash-ref supplied-settings key (hash-ref stored-settings key ""))))
(values key value)))
(let* ((stored-settings (password-reset-mail-settings config))
(supplied-password (hash-ref supplied-settings "smtp-password" ""))
(effective-password
(if (string=? supplied-password "")
(hash-ref stored-settings "smtp-password" "")
supplied-password)))
(for/hash (((key _environment-name) (in-hash setting-environment-names)))
(let ((value
(if (string=? key "smtp-password")
effective-password
(hash-ref supplied-settings key (hash-ref stored-settings key "")))))
(values key value)))))
(define (send-mail-with-settings! settings recipient subject body-lines)
(define host (string-trim (hash-ref settings "smtp-host" "")))
(define from (safe-header-value (string-trim (hash-ref settings "smtp-from" ""))))
(when (string=? host "")
(error 'send-mail-with-settings! "SMTP server is required"))
(when (string=? from "")
(error 'send-mail-with-settings! "Sender address is required"))
(define configured-port (string->number (hash-ref settings "smtp-port" "587")))
(define port
(if (and (exact-integer? configured-port) (<= 1 configured-port 65535))
configured-port
587))
(define configured-user (hash-ref settings "smtp-user" ""))
(define user
(if (string=? configured-user "") #f configured-user))
(define configured-password (hash-ref settings "smtp-password" ""))
(define password
(if (string=? configured-password "") #f configured-password))
(define starttls?
(string-ci=? (hash-ref settings "smtp-tls" "true") "true"))
(define accept-untrusted-certificates?
(string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true"))
(define header
(string-append "From: " from "\r\n"
"To: " (safe-header-value recipient) "\r\n"
"Subject: " (safe-header-value subject) "\r\n"
"MIME-Version: 1.0\r\n"
"Content-Type: text/plain; charset=UTF-8\r\n"
"\r\n"))
(define message
(for/list ((line (in-list body-lines)))
(string->bytes/utf-8 line)))
(with-handlers ((exn:fail?
(λ (exception)
(define message (exn-message exception))
(if (regexp-match? #px"certificate verify failed" message)
(error 'send-mail-with-settings!
"TLS certificate verification failed; install a valid certificate or explicitly accept untrusted certificates for this trusted local SMTP server")
(raise exception)))))
(smtp-send-message host
from
(list recipient)
header
message
#:port-no port
#:auth-user user
#:auth-passwd password
#:tls-encode (if starttls?
(make-starttls-encoder host accept-untrusted-certificates?)
#f))))
(let ((host (string-trim (hash-ref settings "smtp-host" "")))
(from (safe-header-value (string-trim (hash-ref settings "smtp-from" "")))))
(when (string=? host "")
(error 'send-mail-with-settings! "SMTP server is required"))
(when (string=? from "")
(error 'send-mail-with-settings! "Sender address is required"))
(let* ((configured-port (string->number (hash-ref settings "smtp-port" "587")))
(port
(if (and (exact-integer? configured-port) (<= 1 configured-port 65535))
configured-port
587))
(configured-user (hash-ref settings "smtp-user" ""))
(user (if (string=? configured-user "") #f configured-user))
(configured-password (hash-ref settings "smtp-password" ""))
(password (if (string=? configured-password "") #f configured-password))
(starttls? (string-ci=? (hash-ref settings "smtp-tls" "true") "true"))
(accept-untrusted-certificates?
(string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true"))
(header
(string-append "From: " from "\r\n"
"To: " (safe-header-value recipient) "\r\n"
"Subject: " (safe-header-value subject) "\r\n"
"MIME-Version: 1.0\r\n"
"Content-Type: text/plain; charset=UTF-8\r\n"
"\r\n"))
(message
(for/list ((line (in-list body-lines)))
(string->bytes/utf-8 line))))
(with-handlers ((exn:fail?
(λ (exception)
(let ((message (exn-message exception)))
(if (regexp-match? #px"certificate verify failed" message)
(error 'send-mail-with-settings!
"TLS certificate verification failed; install a valid certificate or explicitly accept untrusted certificates for this trusted local SMTP server")
(raise exception))))))
(smtp-send-message host
from
(list recipient)
header
message
#:port-no port
#:auth-user user
#:auth-passwd password
#:tls-encode (if starttls?
(make-starttls-encoder host accept-untrusted-certificates?)
#f))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Test supplied SMTP settings without storing them.
@@ -184,17 +199,17 @@
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-test-mail! config supplied-settings recipient)
(define settings
(settings-with-stored-password config supplied-settings))
(send-mail-with-settings!
settings
recipient
(string-append (wiki-config-site-title config) " SMTP test")
(list (string-append "This is a test message from "
(wiki-config-site-title config)
".")
""
"The SMTP server accepted the message using the settings from the administration form.")))
(let ((settings
(settings-with-stored-password config supplied-settings)))
(send-mail-with-settings!
settings
recipient
(string-append (wiki-config-site-title config) " SMTP test")
(list (string-append "This is a test message from "
(wiki-config-site-title config)
".")
""
"The SMTP server accepted the message using the settings from the administration form."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Send a one-time password-reset link through configured SMTP.
@@ -205,20 +220,20 @@
(define (send-password-reset-mail! config recipient token)
(unless (password-reset-mail-configured? config)
(error 'send-password-reset-mail! "Password-reset email is not configured"))
(define settings (password-reset-mail-settings config))
(define public-url
(string-trim (hash-ref settings "public-url") "/" #:right? #t))
(define reset-url
(string-append public-url "/reset-password?token=" token))
(send-mail-with-settings!
settings
recipient
"Password reset"
(list (string-append "A password reset was requested for your account at "
(wiki-config-site-title config)
".")
""
"Open this link within one hour:"
reset-url
""
"If you did not request this, you can ignore this email.")))
(let* ((settings (password-reset-mail-settings config))
(public-url
(string-trim (hash-ref settings "public-url") "/" #:right? #t))
(reset-url
(string-append public-url "/reset-password?token=" token)))
(send-mail-with-settings!
settings
recipient
"Password reset"
(list (string-append "A password reset was requested for your account at "
(wiki-config-site-title config)
".")
""
"Open this link within one hour:"
reset-url
""
"If you did not request this, you can ignore this email."))))
private/migrations.rkt
+99 -131
View File
@@ -112,6 +112,12 @@ CREATE TABLE IF NOT EXISTS wiki_schema (
SQL
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the newest recorded wiki database schema version.
; pre : db is an open PostgreSQL connection.
; post : Schema tables have only been inspected.
; result : The highest recorded version, or 0 when wiki_schema does not exist.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (database-schema-version db)
(if (table-exists? db "wiki_schema")
(query-value db "SELECT COALESCE(MAX(version), 0) FROM wiki_schema")
@@ -147,51 +153,51 @@ SQL
(install-schema-1! db))))
(define (legacy-mime-type stored-name)
(define lower (string-downcase stored-name))
(cond
((regexp-match? #px"[.]png$" lower) "image/png")
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
((regexp-match? #px"[.]gif$" lower) "image/gif")
((regexp-match? #px"[.]webp$" lower) "image/webp")
((regexp-match? #px"[.]pdf$" lower) "application/pdf")
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
(else "application/octet-stream")))
(let ((lower (string-downcase stored-name)))
(cond
((regexp-match? #px"[.]png$" lower) "image/png")
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
((regexp-match? #px"[.]gif$" lower) "image/gif")
((regexp-match? #px"[.]webp$" lower) "image/webp")
((regexp-match? #px"[.]pdf$" lower) "application/pdf")
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
(else "application/octet-stream"))))
(define (migrate-1->2! db config)
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS mime_type TEXT")
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS content BYTEA")
(define rows
(query-rows db
#<<SQL
(let ((rows
(query-rows db
#<<SQL
SELECT a.id, p.slug, a.stored_name, a.content
FROM attachments a
JOIN pages p ON p.id = a.page_id
ORDER BY a.id
SQL
))
(for ((row (in-list rows)))
(define attachment-id (vector-ref row 0))
(define slug (vector-ref row 1))
(define stored-name (vector-ref row 2))
(define content (vector-ref row 3))
(unless (bytes? content)
(define path (build-path (uploads-directory config) slug stored-name))
(unless (file-exists? path)
(error 'migrate-database!
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
stored-name
(path->string path)))
(define bytes (file->bytes path))
(query-exec db
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
bytes
(legacy-mime-type stored-name)
(bytes-length bytes)
attachment-id)))
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL")
(query-exec db "ALTER TABLE attachments ALTER COLUMN mime_type SET NOT NULL")
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
(record-schema-version! db 2))
)))
(for ((row (in-list rows)))
(let ((attachment-id (vector-ref row 0))
(slug (vector-ref row 1))
(stored-name (vector-ref row 2))
(content (vector-ref row 3)))
(unless (bytes? content)
(let ((path (build-path (uploads-directory config) slug stored-name)))
(unless (file-exists? path)
(error 'migrate-database!
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
stored-name
(path->string path)))
(let ((bytes (file->bytes path)))
(query-exec db
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
bytes
(legacy-mime-type stored-name)
(bytes-length bytes)
attachment-id))))))
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL")
(query-exec db "ALTER TABLE attachments ALTER COLUMN mime_type SET NOT NULL")
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
(record-schema-version! db 2)))
(define (replace-page-todos! db page-id markdown)
@@ -1092,10 +1098,10 @@ CREATE TEMP TABLE concept_uuid_rekey (
) ON COMMIT DROP
SQL
)
(define old-ids
(query-list
db
#<<SQL
(let* ((old-ids
(query-list
db
#<<SQL
WITH all_current_ids AS (
SELECT id AS old_id FROM concept_definitions
UNION
@@ -1119,27 +1125,28 @@ FROM all_current_ids
WHERE nullif(old_id, '') IS NOT NULL
ORDER BY old_id
SQL
))
;; Reserve every already canonical UUID before generating replacements, so a
;; random id can never collide with a UUID encountered later in the query.
(define used-ids (make-hash))
(for ([old-id (in-list old-ids)])
(define normalized (normalize-concept-id old-id))
(when normalized (hash-set! used-ids normalized #t)))
(define (fresh-unused-id)
(let loop ()
(define candidate (new-concept-id))
(if (hash-has-key? used-ids candidate)
(loop)
(begin
(hash-set! used-ids candidate #t)
candidate))))
(for ([old-id (in-list old-ids)])
(query-exec
db
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
old-id
(or (normalize-concept-id old-id) (fresh-unused-id))))
))
;; Reserve every already canonical UUID before generating replacements,
;; so a random id can never collide with a UUID encountered later.
(used-ids (make-hash)))
(for ([old-id (in-list old-ids)])
(let ((normalized (normalize-concept-id old-id)))
(when normalized (hash-set! used-ids normalized #t))))
(letrec ((fresh-unused-id
(λ ()
(let loop ()
(let ((candidate (new-concept-id)))
(if (hash-has-key? used-ids candidate)
(loop)
(begin
(hash-set! used-ids candidate #t)
candidate)))))))
(for ([old-id (in-list old-ids)])
(query-exec
db
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
old-id
(or (normalize-concept-id old-id) (fresh-unused-id)))))
(query-exec
db
#<<SQL
@@ -1205,7 +1212,7 @@ ADD CONSTRAINT concept_definitions_uuid_id_check
CHECK (id ~ '^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$')
SQL
)
(record-schema-version! db 21))
(record-schema-version! db 21)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Bring a racket-wiki PostgreSQL database to the current schema.
@@ -1219,72 +1226,33 @@ SQL
db
(λ ()
(recognize-or-install-schema-1! db)
(define version (database-schema-version db))
(when (< version 1)
(error 'migrate-database! "unable to determine the existing wiki database schema"))
(when (= version 1)
(migrate-1->2! db config))
(define after-attachments (database-schema-version db))
(when (= after-attachments 2)
(migrate-2->3! db))
(define after-todos (database-schema-version db))
(when (= after-todos 3)
(migrate-3->4! db))
(define after-bookmarks (database-schema-version db))
(when (= after-bookmarks 4)
(migrate-4->5! db))
(define after-todo-reindex (database-schema-version db))
(when (= after-todo-reindex 5)
(migrate-5->6! db))
(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 after-concept-maps (database-schema-version db))
(when (= after-concept-maps 9)
(migrate-9->10! db))
(define after-user-profiles (database-schema-version db))
(when (= after-user-profiles 10)
(migrate-10->11! db))
(define after-concept-map-history (database-schema-version db))
(when (= after-concept-map-history 11)
(migrate-11->12! db))
(define after-concept-map-history-cleanup (database-schema-version db))
(when (= after-concept-map-history-cleanup 12)
(migrate-12->13! db))
(define after-people (database-schema-version db))
(when (= after-people 13)
(migrate-13->14! db))
(define after-concept-definitions (database-schema-version db))
(when (= after-concept-definitions 14)
(migrate-14->15! db))
(define after-submap-concepts (database-schema-version db))
(when (= after-submap-concepts 15)
(migrate-15->16! db))
(define after-concept-link-aliases (database-schema-version db))
(when (= after-concept-link-aliases 16)
(migrate-16->17! db))
(define after-concept-name-merge (database-schema-version db))
(when (= after-concept-name-merge 17)
(migrate-17->18! db))
(define after-concept-normalization (database-schema-version db))
(when (= after-concept-normalization 18)
(migrate-18->19! db))
(define after-placement-content-cleanup (database-schema-version db))
(when (= after-placement-content-cleanup 19)
(migrate-19->20! db))
(define after-central-concept-references (database-schema-version db))
(when (= after-central-concept-references 20)
(migrate-20->21! db))
(define resulting-version (database-schema-version db))
(when (> resulting-version current-schema-version)
(error 'migrate-database!
"database schema ~a is newer than this racket-wiki supports (~a)"
resulting-version
current-schema-version))
resulting-version)))
(let loop ((version (database-schema-version db)))
(cond
((< version 1)
(error 'migrate-database! "unable to determine the existing wiki database schema"))
((= version 1) (migrate-1->2! db config) (loop (database-schema-version db)))
((= version 2) (migrate-2->3! db) (loop (database-schema-version db)))
((= version 3) (migrate-3->4! db) (loop (database-schema-version db)))
((= version 4) (migrate-4->5! db) (loop (database-schema-version db)))
((= version 5) (migrate-5->6! db) (loop (database-schema-version db)))
((= version 6) (migrate-6->7! db) (loop (database-schema-version db)))
((= version 7) (migrate-7->8! db) (loop (database-schema-version db)))
((= version 8) (migrate-8->9! db) (loop (database-schema-version db)))
((= version 9) (migrate-9->10! db) (loop (database-schema-version db)))
((= version 10) (migrate-10->11! db) (loop (database-schema-version db)))
((= version 11) (migrate-11->12! db) (loop (database-schema-version db)))
((= version 12) (migrate-12->13! db) (loop (database-schema-version db)))
((= version 13) (migrate-13->14! db) (loop (database-schema-version db)))
((= version 14) (migrate-14->15! db) (loop (database-schema-version db)))
((= version 15) (migrate-15->16! db) (loop (database-schema-version db)))
((= version 16) (migrate-16->17! db) (loop (database-schema-version db)))
((= version 17) (migrate-17->18! db) (loop (database-schema-version db)))
((= version 18) (migrate-18->19! db) (loop (database-schema-version db)))
((= version 19) (migrate-19->20! db) (loop (database-schema-version db)))
((= version 20) (migrate-20->21! db) (loop (database-schema-version db)))
((> version current-schema-version)
(error 'migrate-database!
"database schema ~a is newer than this racket-wiki supports (~a)"
version
current-schema-version))
(else version))))))
private/people.rkt
+56 -32
View File
@@ -19,10 +19,16 @@
'name (vector-ref row 1)
'active (vector-ref row 2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List people available for CMap person tags.
; pre : The wiki database schema is initialized.
; post : Person rows have only been read.
; result : A name-sorted list of person hashes, optionally excluding inactive rows.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-people config [include-inactive? #t])
(call-with-wiki-database
config
(lambda (db)
(λ (db)
(for/list ((row (in-list
(query-rows
db
@@ -35,45 +41,57 @@
(define (clean-person-name who name)
(unless (string? name)
(raise-argument-error who "string?" name))
(define clean (string-trim name))
(when (or (string=? clean "") (> (string-length clean) 200))
(error who "person name must contain between 1 and 200 characters"))
clean)
(let ((clean (string-trim name)))
(when (or (string=? clean "") (> (string-length clean) 200))
(error who "person name must contain between 1 and 200 characters"))
clean))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create or reactivate a person in the shared registry.
; pre : name is a string containing between 1 and 200 non-whitespace characters.
; post : A matching person exists and is active.
; result : The stored person hash.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-person! config name)
(define clean-name (clean-person-name 'create-person! name))
(call-with-wiki-database
config
(lambda (db)
(define now (current-seconds))
(row->person
(query-row
db
#<<SQL
(let ((clean-name (clean-person-name 'create-person! name)))
(call-with-wiki-database
config
(λ (db)
(let ((now (current-seconds)))
(row->person
(query-row
db
#<<SQL
INSERT INTO people(name, active, created_at, updated_at)
VALUES ($1, TRUE, $2, $2)
ON CONFLICT (lower(name)) DO UPDATE
SET name = excluded.name, active = TRUE, updated_at = excluded.updated_at
RETURNING id, name, active
SQL
clean-name now)))))
clean-name now)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Change the name and active state of one registered person.
; pre : id identifies a possible person and name is valid registry text.
; post : The matching row, when present, contains the supplied values.
; result : The updated person hash, or #f when id does not exist.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-person! config id name active?)
(define clean-name (clean-person-name 'update-person! name))
(call-with-wiki-database
config
(lambda (db)
(define row
(query-maybe-row
db
#<<SQL
(let ((clean-name (clean-person-name 'update-person! name)))
(call-with-wiki-database
config
(λ (db)
(let ((row
(query-maybe-row
db
#<<SQL
UPDATE people
SET name = $1, active = $2, updated_at = $3
WHERE id = $4
RETURNING id, name, active
SQL
clean-name (if active? #t #f) (current-seconds) id))
(and row (row->person row)))))
clean-name (if active? #t #f) (current-seconds) id)))
(and row (row->person row)))))))
(define (person-tag-names document)
(remove-duplicates
@@ -91,18 +109,24 @@ SQL
;; Called inside the concept-map write transaction. New names become active;
;; an explicitly deactivated existing name remains deactivated.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Add previously unknown person tags from a CMap document.
; pre : db is inside the CMap write transaction and document is a CMap hash.
; post : Every distinct person tag has a registry row; existing rows are unchanged.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (sync-person-tags! db document)
(define now (current-seconds))
(for ((name (in-list (person-tag-names document))))
(query-exec
db
#<<SQL
(let ((now (current-seconds)))
(for ((name (in-list (person-tag-names document))))
(query-exec
db
#<<SQL
INSERT INTO people(name, active, created_at, updated_at)
VALUES ($1, TRUE, $2, $2)
ON CONFLICT (lower(name)) DO NOTHING
SQL
name now))
(void))
name now))
(void)))
(module+ test
(require rackunit)
private/setup.rkt
+92 -92
View File
@@ -24,10 +24,10 @@
(define (bytes->hex value)
(apply string-append
(for/list ((byte (in-bytes value)))
(define hex (number->string byte 16))
(if (= (string-length hex) 1)
(string-append "0" hex)
hex))))
(let ((hex (number->string byte 16)))
(if (= (string-length hex) 1)
(string-append "0" hex)
hex)))))
(define setup-form-token
(bytes->hex (crypto-random-bytes 32)))
@@ -49,16 +49,16 @@
(vendor-files-ready? config)))
(define (request-form req)
(define body (request-post-data/raw req))
(if body
(form-urlencoded->alist (bytes->string/utf-8 body))
'()))
(let ((body (request-post-data/raw req)))
(if body
(form-urlencoded->alist (bytes->string/utf-8 body))
'())))
(define (form-value form key [default ""])
(define found (assoc key form))
(if (and found (cdr found))
(cdr found)
default))
(let ((found (assoc key form)))
(if (and found (cdr found))
(cdr found)
default)))
(define setup-style
#<<CSS
@@ -96,21 +96,21 @@ CSS
(define (language-field config [form '()])
(define language (form-value form 'language (current-language config)))
`((label
,(tr config 'language)
(select ((name "language"))
(option ((value "en") ,@(if (string-ci=? language "en") '((selected "selected")) '())) ,(tr config 'language-en))
(option ((value "nl") ,@(if (string-ci=? language "nl") '((selected "selected")) '())) ,(tr config 'language-nl))))))
(let ((language (form-value form 'language (current-language config))))
`((label
,(tr config 'language)
(select ((name "language"))
(option ((value "en") ,@(if (string-ci=? language "en") '((selected "selected")) '())) ,(tr config 'language-en))
(option ((value "nl") ,@(if (string-ci=? language "nl") '((selected "selected")) '())) ,(tr config 'language-nl)))))))
(define (database-fields config [form '()])
(define settings (read-database-settings config))
(define ssl-text
(form-value form
'db-ssl
(symbol->string (setting-value settings database-settings-ssl 'no))))
(define ssl (string->symbol ssl-text))
`((h2 ,(tr config 'postgresql))
(let* ((settings (read-database-settings config))
(ssl-text
(form-value form
'db-ssl
(symbol->string (setting-value settings database-settings-ssl 'no))))
(ssl (string->symbol ssl-text)))
`((h2 ,(tr config 'postgresql))
(div ((class "fields"))
(label
,(tr config 'server)
@@ -147,7 +147,7 @@ CSS
(select ((name "db-ssl"))
(option ((value "no") ,@(if (eq? ssl 'no) '((selected "selected")) '())) ,(tr config 'ssl-no))
(option ((value "optional") ,@(if (eq? ssl 'optional) '((selected "selected")) '())) ,(tr config 'ssl-optional))
(option ((value "yes") ,@(if (eq? ssl 'yes) '((selected "selected")) '())) ,(tr config 'ssl-required)))))))
(option ((value "yes") ,@(if (eq? ssl 'yes) '((selected "selected")) '())) ,(tr config 'ssl-required))))))))
(define (admin-fields config [form '()])
`((h2 ,(tr config 'administrator))
@@ -177,10 +177,10 @@ CSS
(required "required"))))))
(define (setup-page config [message #f] [form '()])
(define db-ready? (database-ready? config))
(define administrator-ready? (admin-ready? config))
(define vendor-ready? (vendor-files-ready? config))
`(html
(let ((db-ready? (database-ready? config))
(administrator-ready? (admin-ready? config))
(vendor-ready? (vendor-files-ready? config)))
`(html
(head
(meta ((charset "utf-8")))
(meta ((name "viewport") (content "width=device-width, initial-scale=1")))
@@ -210,7 +210,7 @@ CSS
(p ((class "note"))
"Frontend libraries are stored below "
(code ,(path->string (vendor-directory config)))
" and are served locally after setup.")))))
" and are served locally after setup."))))))
(define (setup-page-response config [message #f] [form '()])
(html-response
@@ -218,85 +218,85 @@ CSS
#:headers (list (make-header #"Cache-Control" #"no-store"))))
(define (validate-admin-form form)
(define username (string-trim (form-value form 'username)))
(define display-name (string-trim (form-value form 'display-name)))
(define password (form-value form 'password))
(define password-confirm (form-value form 'password-confirm))
(cond
((string=? username "") "Administrator username is required.")
((string=? password "") "Administrator password is required.")
((< (string-length password) 8) "Administrator password must contain at least 8 characters.")
((not (string=? password password-confirm)) "The two passwords do not match.")
(else
(list username
(if (string=? display-name "") username display-name)
password))))
(let ((username (string-trim (form-value form 'username)))
(display-name (string-trim (form-value form 'display-name)))
(password (form-value form 'password))
(password-confirm (form-value form 'password-confirm)))
(cond
((string=? username "") "Administrator username is required.")
((string=? password "") "Administrator password is required.")
((< (string-length password) 8) "Administrator password must contain at least 8 characters.")
((not (string=? password password-confirm)) "The two passwords do not match.")
(else
(list username
(if (string=? display-name "") username display-name)
password)))))
(define (form->database-settings form)
(define port (string->number (form-value form 'db-port "5432")))
(define ssl-text (form-value form 'db-ssl "no"))
(define ssl
(let* ((port (string->number (form-value form 'db-port "5432")))
(ssl-text (form-value form 'db-ssl "no"))
(ssl
(cond
((string=? ssl-text "yes") 'yes)
((string=? ssl-text "optional") 'optional)
(else 'no))))
(cond
((string=? ssl-text "yes") 'yes)
((string=? ssl-text "optional") 'optional)
(else 'no)))
(cond
((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.")
((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.")
((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.")
((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.")
(else
(database-settings (string-trim (form-value form 'db-server))
port
(string-trim (form-value form 'db-database))
(string-trim (form-value form 'db-user))
(form-value form 'db-password)
ssl))))
((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.")
((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.")
((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.")
((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.")
(else
(database-settings (string-trim (form-value form 'db-server))
port
(string-trim (form-value form 'db-database))
(string-trim (form-value form 'db-user))
(form-value form 'db-password)
ssl)))))
(define (configure-language! config form)
(define language (string-downcase (form-value form 'language (current-language config))))
(unless (member language '("en" "nl"))
(error 'setup "Unsupported UI language: ~a" language))
(write-language! config language))
(let ((language (string-downcase (form-value form 'language (current-language config)))))
(unless (member language '("en" "nl"))
(error 'setup "Unsupported UI language: ~a" language))
(write-language! config language)))
(define (configure-database! config form)
(unless (database-ready? config)
(define settings (form->database-settings form))
(when (string? settings)
(error 'setup settings))
(test-database-settings! settings)
(initialize-database-with-settings! settings config)
(write-database-settings! config settings)))
(let ((settings (form->database-settings form)))
(when (string? settings)
(error 'setup settings))
(test-database-settings! settings)
(initialize-database-with-settings! settings config)
(write-database-settings! config settings))))
(define (configure-administrator! config form)
(unless (admin-ready? config)
(define admin-values (validate-admin-form form))
(when (string? admin-values)
(error 'setup admin-values))
(create-user! config
(list-ref admin-values 0)
(list-ref admin-values 1)
(list-ref admin-values 2)
'admin
'enabled)))
(let ((admin-values (validate-admin-form form)))
(when (string? admin-values)
(error 'setup admin-values))
(create-user! config
(list-ref admin-values 0)
(list-ref admin-values 1)
(list-ref admin-values 2)
'admin
'enabled))))
(define (cleartext-password-error? message)
(and (string? message)
(regexp-match? #rx"refusing to send cleartext password" message)))
(define (setup-error-message e)
(define message (exn-message e))
(if (cleartext-password-error? message)
(string-append
"PostgreSQL requests cleartext password authentication. "
"Configure the matching pg_hba.conf rule for this database/user to use "
"scram-sha-256 (recommended), then reload PostgreSQL and try again. "
"If more than one pg_hba.conf rule could match, remember that PostgreSQL "
"uses the first matching rule. "
"The entered non-password fields have been preserved below.\n\n"
"Technical detail: " message)
message))
(let ((message (exn-message e)))
(if (cleartext-password-error? message)
(string-append
"PostgreSQL requests cleartext password authentication. "
"Configure the matching pg_hba.conf rule for this database/user to use "
"scram-sha-256 (recommended), then reload PostgreSQL and try again. "
"If more than one pg_hba.conf rule could match, remember that PostgreSQL "
"uses the first matching rule. "
"The entered non-password fields have been preserved below.\n\n"
"Technical detail: " message)
message)))
(define (complete-setup! config req)
(call-with-semaphore
private/storage.rkt
+263 -252
View File
@@ -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.
private/todo.rkt
+21 -21
View File
@@ -16,24 +16,24 @@
; result : A list of hashes containing item number, line number and text.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (extract-todos markdown)
(define lines (string-split markdown "\n" #:trim? #f))
(define in-fence? #f)
(define item-number 0)
(define result '())
(for ((line (in-list lines))
(line-number (in-naturals 1)))
(define trimmed (string-trim line))
(cond
((regexp-match? #px"^(```|~~~)" trimmed)
(set! in-fence? (not in-fence?)))
((not in-fence?)
(for ((match (in-list (regexp-match* #px"[Tt][Oo][Dd][Oo]\\([^()]+\\)" line))))
(define text (string-trim (substring match 5 (- (string-length match) 1))))
(when (not (string=? text ""))
(set! item-number (+ item-number 1))
(set! result
(cons (hash 'number item-number
'line line-number
'text text)
result)))))))
(reverse result))
(let ((lines (string-split markdown "\n" #:trim? #f))
(in-fence? #f)
(item-number 0)
(result '()))
(for ((line (in-list lines))
(line-number (in-naturals 1)))
(let ((trimmed (string-trim line)))
(cond
((regexp-match? #px"^(```|~~~)" trimmed)
(set! in-fence? (not in-fence?)))
((not in-fence?)
(for ((match (in-list (regexp-match* #px"[Tt][Oo][Dd][Oo]\\([^()]+\\)" line))))
(let ((text (string-trim (substring match 5 (- (string-length match) 1)))))
(when (not (string=? text ""))
(set! item-number (+ item-number 1))
(set! result
(cons (hash 'number item-number
'line line-number
'text text)
result)))))))))
(reverse result)))
private/vendor.rkt
+39 -39
View File
@@ -39,9 +39,9 @@
"https://cdn.jsdelivr.net/npm/diff2html@3.4.56/bundles/css/diff2html.min.css")))
(define (vendor-file-ready? config name)
(define path (build-path (vendor-directory config) name))
(and (file-exists? path)
(> (file-size path) 0)))
(let ((path (build-path (vendor-directory config) name)))
(and (file-exists? path)
(> (file-size path) 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether all required browser libraries are installed.
@@ -56,40 +56,40 @@
(define (download-content source)
(parameterize ((current-https-protocol 'secure))
(define-values (in headers)
(get-pure-port/headers (string->url source)
'()
#:redirections 5
#:status? #t))
(dynamic-wind
void
(λ ()
(define status-match
(regexp-match #px"^HTTP/[^ ]+ ([0-9][0-9][0-9])" headers))
(unless (and status-match
(= (string->number (list-ref status-match 1)) 200))
(error 'download-vendor-files!
"download failed for ~a: ~a"
source
(or (and status-match (list-ref status-match 1))
"invalid HTTP status")))
(port->bytes in))
(λ ()
(close-input-port in)))))
(let-values (((in headers)
(get-pure-port/headers (string->url source)
'()
#:redirections 5
#:status? #t)))
(dynamic-wind
void
(λ ()
(let ((status-match
(regexp-match #px"^HTTP/[^ ]+ ([0-9][0-9][0-9])" headers)))
(unless (and status-match
(= (string->number (list-ref status-match 1)) 200))
(error 'download-vendor-files!
"download failed for ~a: ~a"
source
(or (and status-match (list-ref status-match 1))
"invalid HTTP status")))
(port->bytes in)))
(λ ()
(close-input-port in))))))
(define (download-file! config name source)
(define directory (vendor-directory config))
(define target (build-path directory name))
(define temporary-target
(build-path directory (string-append name ".download")))
(define content (download-content source))
(make-directory* (path-only target))
(call-with-output-file temporary-target
(λ (out)
(write-bytes content out))
#:exists 'truncate/replace)
(rename-file-or-directory temporary-target target #t)
(void))
(let* ((directory (vendor-directory config))
(target (build-path directory name))
(temporary-target
(build-path directory (string-append name ".download")))
(content (download-content source)))
(make-directory* (path-only target))
(call-with-output-file temporary-target
(λ (out)
(write-bytes content out))
#:exists 'truncate/replace)
(rename-file-or-directory temporary-target target #t)
(void)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Download all browser libraries required by the wiki frontend.
@@ -101,10 +101,10 @@
(define (download-vendor-files! config)
(make-directory* (vendor-directory config))
(for ([entry (in-list vendor-files)])
(define name (car entry))
(define source (cdr entry))
(unless (vendor-file-ready? config name)
(download-file! config name source)))
(let ((name (car entry))
(source (cdr entry)))
(unless (vendor-file-ready? config name)
(download-file! config name source))))
(unless (vendor-files-ready? config)
(error 'download-vendor-files! "frontend vendor setup is incomplete"))
(void))
scrbl/racket-wiki.scrbl
+24
View File
@@ -150,6 +150,30 @@ for page-local checklists.
@defmodule[racket-wiki/translate]
@defproc[(current-language [config any/c]) string?] {
Returns the language stored for the wiki installation. When no readable
language setting exists, the language in @racket[config] is returned.
}
@defproc[(write-language! [config any/c] [language string?]) void?] {
Stores @racket[language] in the configured wiki data directory.
}
@defproc[(translation-page-slug [language any/c #f]) string?] {
Returns the fixed slug of the special page containing translation overrides.
The optional argument is retained for compatibility with older callers.
}
@defproc[(translation-page-template) string?] {
Builds initial Markdown content containing every built-in Dutch and English
translation key.
}
@defproc[(translations-for [config any/c]) hash?] {
Returns all effective translations for the selected language, including any
valid overrides from the special translations page.
}
@defproc[(tr [config any/c] [key symbol?]) string?] {
Returns the effective UI translation for @racket[key]. Built-in English and
Dutch translations are available before the database is configured. Once the
server.rkt
+9 -9
View File
@@ -357,22 +357,22 @@ CSS
(define (people-list-handler config req)
(require-role
config req 'reader
(lambda (_session)
(λ (_session)
(json-response (hash 'people (list-people config #t))))))
(define (people-create-handler config req)
(require-write-role
config req 'editor
(lambda (_session)
(with-handlers ((exn:fail? (lambda (e) (json-error 400 (exn-message e)))))
(λ (_session)
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
(define body (request-json req))
(json-response (create-person! config (hash-ref body 'name "")) #:code 201)))))
(define (people-update-handler config req id)
(require-write-role
config req 'editor
(lambda (_session)
(with-handlers ((exn:fail? (lambda (e) (json-error 400 (exn-message e)))))
(λ (_session)
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
(define body (request-json req))
(define active (hash-ref body 'active #t))
(unless (boolean? active)
@@ -441,7 +441,7 @@ CSS
(define (concept-map-version-delete-handler config req slug version)
(require-write-role
config req 'editor
(lambda (_session)
(λ (_session)
(if (delete-concept-map-version! config slug version)
(json-response (hash 'ok #t))
(json-error 404 "Concept map history item not found")))))
@@ -841,12 +841,12 @@ CSS
(if (string-ci=? (bytes->string/latin-1 (request-method req)) "GET")
(require-role
config req 'reader
(lambda (_session)
(λ (_session)
(json-response (hash 'styles (or (read-cmap-styles config) 'null)))))
(require-write-role
config req 'editor
(lambda (_session)
(with-handlers ([exn:fail? (lambda (e) (json-error 400 (exn-message e)))])
(λ (_session)
(with-handlers ([exn:fail? (λ (e) (json-error 400 (exn-message e)))])
(define body (request-json req))
(json-response
(hash 'styles
skill/racket-skill.md
-227
View File
@@ -1,227 +0,0 @@
---
name: racket-programmeer-skill
description: Hiermee wordt mijn voorkeur racket programmeerstijl aangegeven.
---
---
name: racket-programmeerstijl
description: Gebruik deze skill wanneer je Racket-code voor Hans schrijft, wijzigt, refactort of beoordeelt. Pas de bestaande, eenvoudige en procedurele programmeerstijl toe; voorkom over-engineering en onnodige abstracties. Gebruik deze skill niet voor algemene uitleg over Racket waarbij geen code voor zijn projecten wordt gemaakt of aangepast.
---
# Racket-programmeerstijl
Gebruik deze stijl wanneer je Racket-code voor Hans schrijft of aanpast.
## Uitgangspunt
Het *allerbelangrijkste* uitgangspunt is dat je de programmerstijl van aangeleverde code volgt.
Als je een zip met een package aangeleverd krijgt via de prompt dan volg je de programmeerstijl die je in de aangeleverde code vindt.
Wanneer bestaande broncode beschikbaar is, heeft de stijl van die broncode voorrang. Sluit daar zo nauw mogelijk op aan.
Schrijf eenvoudige, directe en goed leesbare Racket-code.
Kies de kleinste oplossing die het huidige probleem netjes oplost.
Bouw geen abstraheringslaag voor mogelijk toekomstig gebruik.
En maak geen helpers die alleen maar in de weg staan.
## Structuur
- Houd modules klein en doelgericht.
- Splits functionaliteit alleen af naar een private module wanneer die een duidelijk eigen doel heeft.
- Gebruik voor duidelijke secties bij voorkeur commentaar in deze vorm:
```racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
```
of, wanneer dat beter bij de module past:
```racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal state / functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
```
Voor publieke functies:
```racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
```
- Houd `provide` en `require` eenvoudig en overzichtelijk.
- Voeg geen extra framework, wrapperlaag of generieke infrastructuur toe zonder concrete noodzaak.
## pre/postcondities
Geëxporteerde functies/procedures/classes of functies/procedures/classes die daarvoor duidelijk in
aanmerking komen, d.w.z. die die provided zijn of naar verwachting zullen worden, moeten gedocumenteerd worden.
Zowel in een module scribble als in de code zelf. In het engels.
In de code zelf: minimaal:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : <doel>
; pre : <preconditie(s)>
; post : <postconditie(s)>
; [result:] <resultaat en onder welke conditie>
Over het algemeen wil je de internals van een functie weten. Hoe werkt het en waarom werkt het zo.
; [internals:]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Als een functie/procedure/class overduidelijk in aanmerking komt voor 'provide' en hij staat er nog niet in.
Verzamel dan de lijst en vraag of je ze moet toevoegen.
## Procedures en control flow
- Geef de voorkeur aan gewone procedures met een direct leesbare control flow.
- Gebruik van `let`, `let*`, `letrec`, `if`, `when`, `unless`, `begin` en `cond` heeft de voorkeur.
- `map`, `filter`, en dat soort constructies gaan boven meer abstracte constructies als `for/or`, etc.
- Gebruik bij voorkeur geen `define` binnen een procedure, tenzij het echt om een locale
functie definitie gaat die een dermate omvang krijgt dat het binnen de closure gerechtvaardigd is.
- `let-values` is prima om te gebruiken.
- Maak niet voor iedere kleine stap een aparte helperprocedure.
- Introduceer geen hogere-orde of functionele constructies alleen omdat dat compacter kan.
- Gebruik recursie of een named `let` wanneer dat de meest directe oplossing is.
- Gebruik bij `cond` bij voorkeur deze vorm:
```racket
(cond
([condition] korte body)
([other-condition]
langere body))
(else ... alleen als het nodig is)
```
## Mate van abstractie vs leesbaarheid
Liever concreet dan abstract.
Geef expliciete, goed leesbare constructies de voorkeur boven compacte abstracte idiomen.
Bijvoorbeeld combinaties als (filter values (list (and condition 'symbol) ...)).
Schrijf dan liever expliciet (filter (lambda (x) x) (list (if condition 'symbol #f) ...)).
Vermijd vooral het stapelen van meerdere impliciete idiomen wanneer dat de leesbaarheid vermindert.
## Gebruik lambda.
Geef de voorkeur aan λ boven lambda.
## Waarden en state
- Gebruik `#f` als normale waarde voor "niet gevonden", "niet beschikbaar" of "nog niet geïnitialiseerd" wanneer dat natuurlijk past.
- Expliciete vergelijkingen zoals `(eq? value #f)` zijn prima wanneer dat de bedoeling duidelijk maakt.
- Houd state eenvoudig. Een gewone modulevariabele zoals `cached-git-exe` is prima wanneer daarvoor geen zwaarder mechanisme nodig is.
- Gebruik geen parameters, structs, classes of objectlagen wanneer een gewone variabele of procedure voldoende is.
## Publieke API
- Gebruik `define/contract` voor publieke procedures wanneer een contract nuttige documentatie en controle geeft.
- Houd publieke procedures klein en voorspelbaar.
- Verander een bestaande publieke API niet zonder noodzaak.
- Voeg geen extra publieke functies toe voor hypothetische toekomstige behoeften.
## Fouten en interactie
- Geef duidelijke en concrete foutmeldingen.
- Los eenvoudige interactieve invoer lokaal en procedureel op.
- Maak foutafhandeling niet generieker dan nodig.
- Als een externe executable of voorziening ontbreekt, meld precies wat ontbreekt en wat de gebruiker kan doen.
## Configuratie
- Bewaar lokale configuratie in een kleine, afzonderlijke private module wanneer dat de hoofdmodule eenvoudiger maakt.
- Gebruik bestaande projectvoorzieningen, zoals `simple-ini`, rechtstreeks in plaats van er een extra abstractielaag omheen te bouwen.
- Dupliceer geen configuratie die al door een extern programma zelf wordt beheerd.
## Naamgeving en leesbaarheid
- Kies concrete, korte namen die passen bij de bestaande code.
- Gebruik Engels voor identifiers en technische namen wanneer de bestaande code dat doet.
- Schrijf comments alleen wanneer ze iets toevoegen dat niet al vanzelf uit de code blijkt.
- Geef de voorkeur aan een paar duidelijke regels boven een compacte maar moeilijker leesbare expressie.
## Vermijd
Vermijd zonder concrete noodzaak:
- over-engineering;
- generieke wrappers;
- extra abstraheringslagen;
- dynamische `require`-constructies;
- classes wanneer procedures volstaan;
- structs wanneer een eenvoudige waarde volstaat;
- configuratie-objecten of dependency-injectionpatronen;
- veel kleine helperprocedures die de control flow versnipperen;
- refactors die alleen bedoeld zijn om code "slimmer" of abstracter te maken.
## Werkwijze bij aanpassen van bestaande code
1. Lees eerst de omliggende module(s).
2. Neem naamgeving, inspringing, control-flow-stijl en module-indeling over.
3. Wijzig alleen wat voor de gevraagde stap nodig is.
4. Houd bestaande werkende code intact als er geen reden is die te veranderen.
5. Voeg geen volgende architectuurstappen alvast toe.
6. Controleer of de oplossing eenvoudiger is dan het probleem; zo niet, vereenvoudig.
## Referentiestijl
Deze vorm is representatief:
```racket
(define cached-value #f)
(define/contract (get-value)
(-> (or/c path? #f))
(if (eq? cached-value #f)
(let ((value (find-value)))
(set! cached-value value)
value)
cached-value))
```
Een wat langere maar direct leesbare implementatie heeft de voorkeur boven een kortere oplossing met meerdere nieuwe abstracties.
# Schrijven van testgevallen voor modules/packages
Een test die alleen werkt vanuit de development directory, op het development-OS of met de lokale shell/environment is geen geldige package-test.
## Racket Package Index / build-service tests
Behandel de Racket Package Index/build service als een aparte, strikte
en onbekende testomgeving.
Bij packagecode en tests gelden daarom altijd de volgende regels:
- Maak nooit aannames over `current-directory` of de directory van waaruit
code of tests worden uitgevoerd. Bepaal testdata en paden expliciet en
relocatable, bijvoorbeeld met runtime paths en tijdelijke directories.
- Maak nooit impliciete aannames over het besturingssysteem. Vermijd
OS-specifieke paden, shells, executables en gedrag, of handel verschillen
expliciet per platform af.
- Maak tests onafhankelijk van lokale environment state. Benodigde
environment variables moeten expliciet en bij voorkeur geïsoleerd worden
ingesteld.
- Een succesvolle test moet stil en ondubbelzinnig succesvol zijn.
Laat geen verwachte foutmeldingen naar de echte stdout/stderr lekken,
omdat `raco test --drdr` en de Package Index dergelijke output als een
mogelijke test failure kunnen classificeren.
- Verwachte foutoutput moet worden gecaptureerd en geassert.
- Tests moeten hun eigen tijdelijke state en testbestanden aanmaken en
mogen geen bestanden, processen, environment changes of andere state
achterlaten.
- Test packagewijzigingen waar mogelijk ook in een omgeving die lijkt op:
`raco setup --check-pkg-deps` en
`raco test --drdr --package <package>`.
translate.rkt
+65 -53
View File
@@ -279,15 +279,27 @@
(define (base-translations language)
(if (string-ci=? language "nl") dutch english))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the language selected for this wiki installation.
; pre : config is a wiki-config value.
; post : The language file, when present, has only been read.
; result : The stored language string, or the language from config as fallback.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (current-language config)
(with-handlers ((exn:fail? (λ (_e) (wiki-config-language config))))
(if (file-exists? (language-config-path config))
(call-with-input-file (language-config-path config)
(λ (in)
(define value (read in))
(if (string? value) value (wiki-config-language config))))
(let ((value (read in)))
(if (string? value) value (wiki-config-language config)))))
(wiki-config-language config))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Persist the selected wiki language.
; pre : config is a wiki-config value and language is a string.
; post : language.rktd contains language below the configured data directory.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (write-language! config language)
(make-directory* (wiki-config-data-dir config))
(call-with-output-file (language-config-path config)
@@ -325,26 +337,26 @@
; result : Text containing every known key with nl and en values.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translation-page-template)
(define keys
(sort (remove-duplicates (append (hash-keys english) (hash-keys dutch)))
string<?
#:key symbol->string))
(string-join
(for/list ((key (in-list keys)))
(format "~a = nl:~a, en:~a"
(symbol->string key)
(translation-value->text (hash-ref dutch key (hash-ref english key "")))
(translation-value->text (hash-ref english key ""))))
"\n"))
(let ((keys
(sort (remove-duplicates (append (hash-keys english) (hash-keys dutch)))
string<?
#:key symbol->string)))
(string-join
(for/list ((key (in-list keys)))
(format "~a = nl:~a, en:~a"
(symbol->string key)
(translation-value->text (hash-ref dutch key (hash-ref english key "")))
(translation-value->text (hash-ref english key ""))))
"\n")))
(define (unquote-translation-value value)
(define text (string-trim value))
(if (and (>= (string-length text) 2)
(char=? (string-ref text 0) #\")
(char=? (string-ref text (sub1 (string-length text))) #\"))
(let ((body (substring text 1 (sub1 (string-length text)))))
(string-replace (string-replace body "\\\"" "\"") "\\\\" "\\"))
text))
(let ((text (string-trim value)))
(if (and (>= (string-length text) 2)
(char=? (string-ref text 0) #\")
(char=? (string-ref text (sub1 (string-length text))) #\"))
(let ((body (substring text 1 (sub1 (string-length text)))))
(string-replace (string-replace body "\\\"" "\"") "\\\\" "\\"))
text)))
(define (split-translation-variants text)
(let loop ((i 0)
@@ -370,24 +382,24 @@
(define (parse-translation-variants text)
(for/fold ((result (hash)))
((part (in-list (split-translation-variants text))))
(define match (regexp-match #px"^\\s*([A-Za-z][A-Za-z0-9_-]*)\\s*:(.*)$" part))
(if match
(hash-set result
(string-downcase (list-ref match 1))
(unquote-translation-value (list-ref match 2)))
result)))
(let ((match (regexp-match #px"^\\s*([A-Za-z][A-Za-z0-9_-]*)\\s*:(.*)$" part)))
(if match
(hash-set result
(string-downcase (list-ref match 1))
(unquote-translation-value (list-ref match 2)))
result))))
(define (parse-overrides markdown)
(for/fold ((result (hash)))
((line (in-list (string-split markdown "\n"))))
(define match
(regexp-match #px"^\\s*([A-Za-z0-9._-]+)\\s*=\\s*(.*?)\\s*$" line))
(if match
(let ((variants (parse-translation-variants (list-ref match 2))))
(if (zero? (hash-count variants))
result
(hash-set result (string->symbol (list-ref match 1)) variants)))
result)))
(let ((match
(regexp-match #px"^\\s*([A-Za-z0-9._-]+)\\s*=\\s*(.*?)\\s*$" line)))
(if match
(let ((variants (parse-translation-variants (list-ref match 2))))
(if (zero? (hash-count variants))
result
(hash-set result (string->symbol (list-ref match 1)) variants)))
result))))
(define (database-overrides config)
(with-handlers ((exn:fail? (λ (_e) (hash))))
@@ -396,20 +408,20 @@
(call-with-wiki-database
config
(λ (db)
(define markdown
(query-maybe-value db
"SELECT markdown FROM pages WHERE namespace = '' AND slug = $1 AND archived = FALSE"
(translation-page-slug)))
(if markdown (parse-overrides markdown) (hash)))))))
(let ((markdown
(query-maybe-value db
"SELECT markdown FROM pages WHERE namespace = '' AND slug = $1 AND archived = FALSE"
(translation-page-slug))))
(if markdown (parse-overrides markdown) (hash))))))))
(define (translation-override-for-language variants language)
(define language-key (string-downcase language))
(cond
((hash-has-key? variants language-key)
(hash-ref variants language-key))
((hash-has-key? variants "en")
(hash-ref variants "en"))
(else #f)))
(let ((language-key (string-downcase language)))
(cond
((hash-has-key? variants language-key)
(hash-ref variants language-key))
((hash-has-key? variants "en")
(hash-ref variants "en"))
(else #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Return all translations active for the configured wiki language.
@@ -418,13 +430,13 @@
; result : A hash from translation symbols to strings.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translations-for config)
(define language (current-language config))
(for/fold ((result (base-translations language)))
(((key variants) (in-hash (database-overrides config))))
(define value (translation-override-for-language variants language))
(if value
(hash-set result key value)
result)))
(let ((language (current-language config)))
(for/fold ((result (base-translations language)))
(((key variants) (in-hash (database-overrides config))))
(let ((value (translation-override-for-language variants language)))
(if value
(hash-set result key value)
result)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Translate one UI key for the configured wiki language.