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) (define (canonical-datum value)
(cond (cond
[(hash? value) [(hash? value)
(define keys (let ((keys
(sort (hash-keys value) (sort (hash-keys value)
string<? string<?
#:key (λ (key) (format "~a" key)))) #:key (λ (key) (format "~a" key)))))
(for/list ([key (in-list keys)]) (for/list ([key (in-list keys)])
(list key (canonical-datum (hash-ref value key))))] (list key (canonical-datum (hash-ref value key)))))]
[(list? value) [(list? value)
(for/list ([item (in-list value)]) (for/list ([item (in-list value)])
(canonical-datum item))] (canonical-datum item))]
[else value])) [else value]))
(define (source-hash value) (define (source-hash value)
(define source-bytes (let ((source-bytes
(string->bytes/utf-8 (string->bytes/utf-8
(format "~s" (canonical-datum value)))) (format "~s" (canonical-datum value)))))
(bytes->hex-string (sha256-bytes source-bytes))) (bytes->hex-string (sha256-bytes source-bytes))))
(define (read-page-source namespace specification) (define (read-page-source namespace specification)
(define slug (hash-ref specification 'slug)) (let ((slug (hash-ref specification 'slug)))
(architecture-page (architecture-page
(page-reference namespace slug) (page-reference namespace slug)
(hash-ref specification 'title) (hash-ref specification 'title)
(file->string (content-path (hash-ref specification 'file))) (file->string (content-path (hash-ref specification 'file)))
(hash-ref specification 'tags '()))) (hash-ref specification 'tags '()))))
(define (read-concept-map-source specification) (define (read-concept-map-source specification)
(architecture-concept-map (architecture-concept-map
@@ -96,109 +96,107 @@
read-json))) read-json)))
(define (load-architecture-content) (define (load-architecture-content)
(define manifest (read-manifest)) (let ((manifest (read-manifest)))
(unless (hash? manifest) (unless (hash? manifest)
(error 'load-architecture-content "manifest.rktd must contain a hash")) (error 'load-architecture-content "manifest.rktd must contain a hash"))
(define namespace (hash-ref manifest 'namespace)) (let* ((namespace (hash-ref manifest 'namespace))
(define pages (pages
(for/list ([specification (in-list (hash-ref manifest 'pages))]) (for/list ([specification (in-list (hash-ref manifest 'pages))])
(read-page-source namespace specification))) (read-page-source namespace specification)))
(define concept-maps (concept-maps
(for/list ([specification (in-list (hash-ref manifest 'concept-maps))]) (for/list ([specification (in-list (hash-ref manifest 'concept-maps))])
(read-concept-map-source specification))) (read-concept-map-source specification))))
(values namespace pages concept-maps)) (values namespace pages concept-maps))))
(define (duplicate-values values) (define (duplicate-values values)
(define seen (mutable-set)) (let ((seen (mutable-set))
(define duplicates (mutable-set)) (duplicates (mutable-set)))
(for ([value (in-list values)]) (for ([value (in-list values)])
(if (set-member? seen value) (if (set-member? seen value)
(set-add! duplicates value) (set-add! duplicates value)
(set-add! seen value))) (set-add! seen value)))
(sort (set->list duplicates) string<?)) (sort (set->list duplicates) string<?)))
(define (validate-page-links! page page-references concept-map-slugs) (define (validate-page-links! page page-references concept-map-slugs)
(define markdown (architecture-page-markdown page)) (let* ((markdown (architecture-page-markdown page))
(define linked-pages (linked-pages
(regexp-match* (regexp-match*
#px"\\]\\((racket-wiki:[^)#]+)(?:#[^)]*)?\\)" #px"\\]\\((racket-wiki:[^)#]+)(?:#[^)]*)?\\)"
markdown markdown
#:match-select (λ (match) (list-ref match 1)))) #:match-select (λ (match) (list-ref match 1))))
(define embedded-concept-maps (embedded-concept-maps
(for/list ([line (in-list (string-split markdown "\n" #:trim? #f))] (filter-map
#:do [(define match (λ (line)
(regexp-match (let ((match (regexp-match concept-map-embed-pattern line)))
concept-map-embed-pattern (and match (string-trim (list-ref match 1)))))
line))] (string-split markdown "\n" #:trim? #f))))
#:when match) (for ([reference (in-list linked-pages)])
(string-trim (list-ref match 1)))) (unless (set-member? page-references reference)
(for ([reference (in-list linked-pages)]) (error 'validate-racket-wiki-architecture!
(unless (set-member? page-references reference) "page ~a links to unknown architecture page ~a"
(error 'validate-racket-wiki-architecture! (architecture-page-reference page)
"page ~a links to unknown architecture page ~a" reference)))
(architecture-page-reference page) (for ([slug (in-list embedded-concept-maps)])
reference))) (unless (set-member? concept-map-slugs slug)
(for ([slug (in-list embedded-concept-maps)]) (error 'validate-racket-wiki-architecture!
(unless (set-member? concept-map-slugs slug) "page ~a embeds unknown architecture CMap ~a"
(error 'validate-racket-wiki-architecture! (architecture-page-reference page)
"page ~a embeds unknown architecture CMap ~a" slug)))))
(architecture-page-reference page)
slug))))
(define (validate-concept-map! concept-map page-references) (define (validate-concept-map! concept-map page-references)
(define document (architecture-concept-map-document concept-map)) (let ((document (architecture-concept-map-document concept-map)))
(unless (hash? document) (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)
(error 'validate-racket-wiki-architecture! (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))) (architecture-concept-map-slug concept-map)))
(define source-id (hash-ref connector 'sourceId #f)) (unless (equal? (hash-ref document 'schemaVersion #f) 1)
(define 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! (error 'validate-racket-wiki-architecture!
"CMap ~a contains a connector with an unknown endpoint" "CMap ~a does not use schema version 1"
(architecture-concept-map-slug concept-map))))) (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. ; goal : Validate every bundled page, link and CMap before importing.
@@ -207,42 +205,40 @@
; result : Two values containing the validated pages and CMaps. ; result : Two values containing the validated pages and CMaps.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (validate-racket-wiki-architecture!) (define (validate-racket-wiki-architecture!)
(define-values (namespace pages concept-maps) (let-values (((namespace pages concept-maps)
(load-architecture-content)) (load-architecture-content)))
(unless (string=? namespace "racket-wiki") (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)
(error 'validate-racket-wiki-architecture! (error 'validate-racket-wiki-architecture!
"invalid page reference: ~a" "the architecture namespace must be racket-wiki"))
reference))) (let* ((page-reference-list (map architecture-page-reference pages))
(for ([slug (in-list concept-map-slug-list)]) (concept-map-slug-list (map architecture-concept-map-slug concept-maps))
(unless (valid-slug? slug) (duplicate-pages (duplicate-values page-reference-list))
(error 'validate-racket-wiki-architecture! (duplicate-concept-maps (duplicate-values concept-map-slug-list)))
"invalid CMap slug: ~a" (unless (null? duplicate-pages)
slug))) (error 'validate-racket-wiki-architecture!
(define page-references (list->set page-reference-list)) "duplicate page references: ~a"
(define concept-map-slugs (list->set concept-map-slug-list)) (string-join duplicate-pages ", ")))
(for ([page (in-list pages)]) (unless (null? duplicate-concept-maps)
(validate-page-links! page page-references concept-map-slugs)) (error 'validate-racket-wiki-architecture!
(for ([concept-map (in-list concept-maps)]) "duplicate CMap slugs: ~a"
(validate-concept-map! concept-map page-references)) (string-join duplicate-concept-maps ", ")))
(values pages 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 ;; Source ownership markers
@@ -256,11 +252,11 @@
markdown)) markdown))
(define (page-source-unmodified? title markdown tags) (define (page-source-unmodified? title markdown tags)
(define match (regexp-match page-source-marker-pattern markdown)) (let ((match (regexp-match page-source-marker-pattern markdown)))
(and match (and match
(let ([body (regexp-replace page-source-marker-pattern markdown "")] (let ((body (regexp-replace page-source-marker-pattern markdown ""))
[stored-hash (list-ref match 1)]) (stored-hash (list-ref match 1)))
(string=? stored-hash (source-hash (list title body tags)))))) (string=? stored-hash (source-hash (list title body tags)))))))
(define (concept-map-source-marker? reference) (define (concept-map-source-marker? reference)
(and (hash? reference) (and (hash? reference)
@@ -268,33 +264,33 @@
concept-map-source-marker-id))) concept-map-source-marker-id)))
(define (concept-map-without-source-marker document) (define (concept-map-without-source-marker document)
(define references (hash-ref document 'conceptMaps '())) (let ((references (hash-ref document 'conceptMaps '())))
(hash-set document (hash-set document
'conceptMaps 'conceptMaps
(filter (λ (reference) (filter (λ (reference)
(not (concept-map-source-marker? reference))) (not (concept-map-source-marker? reference)))
references))) references))))
(define (concept-map-with-source-marker title document) (define (concept-map-with-source-marker title document)
(define clean-document (concept-map-without-source-marker document)) (let* ((clean-document (concept-map-without-source-marker document))
(define marker (marker
(hash 'id concept-map-source-marker-id (hash 'id concept-map-source-marker-id
'kind "architecture-source" 'kind "architecture-source"
'sourceHash (source-hash (list title clean-document)))) 'sourceHash (source-hash (list title clean-document)))))
(hash-set clean-document (hash-set clean-document
'conceptMaps 'conceptMaps
(append (hash-ref clean-document 'conceptMaps '()) (append (hash-ref clean-document 'conceptMaps '())
(list marker)))) (list marker)))))
(define (concept-map-source-unmodified? title document) (define (concept-map-source-unmodified? title document)
(define marker (let ((marker
(findf concept-map-source-marker? (findf concept-map-source-marker?
(hash-ref document 'conceptMaps '()))) (hash-ref document 'conceptMaps '()))))
(and marker (and marker
(string=? (hash-ref marker 'sourceHash "") (string=? (hash-ref marker 'sourceHash "")
(source-hash (source-hash
(list title (list title
(concept-map-without-source-marker document)))))) (concept-map-without-source-marker document)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Import operations ;; Import operations
@@ -312,13 +308,13 @@
(architecture-page-tags page)))) (architecture-page-tags page))))
(define (import-page! config page author dry-run? overwrite-modified?) (define (import-page! config page author dry-run? overwrite-modified?)
(define reference (architecture-page-reference page)) (let* ((reference (architecture-page-reference page))
(define marked-markdown (marked-markdown
(page-with-source-marker (architecture-page-title page) (page-with-source-marker (architecture-page-title page)
(architecture-page-markdown page) (architecture-page-markdown page)
(architecture-page-tags page))) (architecture-page-tags page)))
(define current (read-page config reference)) (current (read-page config reference)))
(cond (cond
[(not current) [(not current)
(if dry-run? (if dry-run?
(result 'page reference 'would-create "Page would be created") (result 'page reference 'would-create "Page would be created")
@@ -355,7 +351,7 @@
(hash-ref current 'currentVersion) (hash-ref current 'currentVersion)
"Updated racket-wiki architecture documentation" "Updated racket-wiki architecture documentation"
(architecture-page-tags page)) (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) (define (concept-map-content-equal? current concept-map marked-document)
(and (string=? (hash-ref current 'title) (and (string=? (hash-ref current 'title)
@@ -364,13 +360,13 @@
marked-document))) marked-document)))
(define (import-concept-map! config concept-map author dry-run? overwrite-modified?) (define (import-concept-map! config concept-map author dry-run? overwrite-modified?)
(define slug (architecture-concept-map-slug concept-map)) (let* ((slug (architecture-concept-map-slug concept-map))
(define marked-document (marked-document
(concept-map-with-source-marker (concept-map-with-source-marker
(architecture-concept-map-title concept-map) (architecture-concept-map-title concept-map)
(architecture-concept-map-document concept-map))) (architecture-concept-map-document concept-map)))
(define current (read-concept-map config slug)) (current (read-concept-map config slug)))
(cond (cond
[(not current) [(not current)
(if dry-run? (if dry-run?
(result 'concept-map slug 'would-create "CMap would be created") (result 'concept-map slug 'would-create "CMap would be created")
@@ -405,7 +401,7 @@
(hash-ref current 'currentVersion) (hash-ref current 'currentVersion)
"Updated racket-wiki architecture CMap" "Updated racket-wiki architecture CMap"
"import") "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. ; goal : Import the bundled architecture set below namespace racket-wiki.
@@ -420,23 +416,23 @@
#:author [author "racket-wiki architecture import"] #:author [author "racket-wiki architecture import"]
#:dry-run? [dry-run? #f] #:dry-run? [dry-run? #f]
#:overwrite-modified? [overwrite-modified? #f]) #:overwrite-modified? [overwrite-modified? #f])
(define-values (pages concept-maps) (let-values (((pages concept-maps)
(validate-racket-wiki-architecture!)) (validate-racket-wiki-architecture!)))
(ensure-wiki-data! config) (ensure-wiki-data! config)
(unless (database-settings-exist? config) (unless (database-settings-exist? config)
(error 'import-racket-wiki-architecture! (error 'import-racket-wiki-architecture!
"PostgreSQL is not configured for data directory ~a" "PostgreSQL is not configured for data directory ~a"
(wiki-config-data-dir config))) (wiki-config-data-dir config)))
(initialize-database! config) (initialize-database! config)
(append (append
(for/list ([page (in-list pages)]) (for/list ([page (in-list pages)])
(import-page! config page author dry-run? overwrite-modified?)) (import-page! config page author dry-run? overwrite-modified?))
(for/list ([concept-map (in-list concept-maps)]) (for/list ([concept-map (in-list concept-maps)])
(import-concept-map! config (import-concept-map! config
concept-map concept-map
author author
dry-run? dry-run?
overwrite-modified?)))) overwrite-modified?)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Import the architecture set using only a wiki data directory. ; goal : Import the architecture set using only a wiki data directory.
@@ -449,13 +445,13 @@
#:author [author "racket-wiki architecture import"] #:author [author "racket-wiki architecture import"]
#:dry-run? [dry-run? #f] #:dry-run? [dry-run? #f]
#:overwrite-modified? [overwrite-modified? #f]) #:overwrite-modified? [overwrite-modified? #f])
(define config (let ((config
(make-wiki-config #:data-dir data-directory)) (make-wiki-config #:data-dir data-directory)))
(import-racket-wiki-architecture! (import-racket-wiki-architecture!
config config
#:author author #:author author
#:dry-run? dry-run? #:dry-run? dry-run?
#:overwrite-modified? overwrite-modified?)) #:overwrite-modified? overwrite-modified?)))
(define (display-import-results results) (define (display-import-results results)
(for ([import-result (in-list results)]) (for ([import-result (in-list results)])
@@ -464,17 +460,17 @@
(architecture-import-result-status import-result) (architecture-import-result-status import-result)
(architecture-import-result-kind import-result) (architecture-import-result-kind import-result)
(architecture-import-result-reference import-result)))) (architecture-import-result-reference import-result))))
(define skipped (let ((skipped
(count (λ (import-result) (count (λ (import-result)
(eq? (architecture-import-result-status import-result) (eq? (architecture-import-result-status import-result)
'skipped-modified)) 'skipped-modified))
results)) results)))
(displayln (format "Processed ~a architecture items." (length results))) (displayln (format "Processed ~a architecture items." (length results)))
(when (> skipped 0) (when (> skipped 0)
(displayln (displayln
(format (format
"~a locally modified item(s) were preserved. Review them before using --overwrite-modified." "~a locally modified item(s) were preserved. Review them before using --overwrite-modified."
skipped)))) skipped)))))
(module+ main (module+ main
(define config (default-wiki-config)) (define config (default-wiki-config))
main.rkt
+9 -9
View File
@@ -30,15 +30,15 @@
#:site-title [site-title "Racket Wiki"] #:site-title [site-title "Racket Wiki"]
#:session-seconds [session-seconds (* 12 60 60)] #:session-seconds [session-seconds (* 12 60 60)]
#:language [language "en"]) #:language [language "en"])
(define config (let ((config
(make-wiki-config #:data-dir data-dir (make-wiki-config #:data-dir data-dir
#:port port #:port port
#:listen-ip listen-ip #:listen-ip listen-ip
#:secure-cookie? secure-cookie? #:secure-cookie? secure-cookie?
#:site-title site-title #:site-title site-title
#:session-seconds session-seconds #:session-seconds session-seconds
#:language language)) #:language language)))
(start-wiki config)) (start-wiki config)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Start the wiki using a configuration. ; 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")) '("system:cmap-subpage-migration" "system:cmap-subpage-migration-repair"))
(define (json-list document key) (define (json-list document key)
(define value (hash-ref document key '())) (let ((value (hash-ref document key '())))
(if (list? value) value '())) (if (list? value) value '())))
(define (parse-document text) (define (parse-document text)
(define first (string->jsexpr text)) (let* ((first (string->jsexpr text))
(define document (if (string? first) (string->jsexpr first) first)) (document (if (string? first) (string->jsexpr first) first)))
(unless (hash? document) (unless (hash? document)
(error 'parse-document "stored CMap document is not an object")) (error 'parse-document "stored CMap document is not an object"))
document) document))
(define (legacy-submap? item) (define (legacy-submap? item)
(and (equal? (hash-ref item 'kind "") "submap") (and (equal? (hash-ref item 'kind "") "submap")
@@ -41,13 +41,13 @@
(and (string? slug) (string=? (string-trim slug) "")))))) (and (string? slug) (string=? (string-trim slug) ""))))))
(define (submap-title item) (define (submap-title item)
(define child-map (hash-ref item 'childMap "")) (let ((child-map (hash-ref item 'childMap ""))
(define label (hash-ref item 'label "")) (label (hash-ref item 'label "")))
(cond ((and (string? child-map) (not (string=? (string-trim child-map) ""))) (cond ((and (string? child-map) (not (string=? (string-trim child-map) "")))
(string-trim child-map)) (string-trim child-map))
((and (string? label) (not (string=? (string-trim label) ""))) ((and (string? label) (not (string=? (string-trim label) "")))
(string-trim label)) (string-trim label))
(else "Sub-CMap"))) (else "Sub-CMap"))))
(define (derived-document source-slug root-id) (define (derived-document source-slug root-id)
(hash 'schemaVersion 2 (hash 'schemaVersion 2
@@ -58,17 +58,17 @@
'conceptMaps '())) 'conceptMaps '()))
(define (link-parent-document document roots) (define (link-parent-document document roots)
(define slugs (let ((slugs
(for/hash ((root (in-list roots))) (for/hash ((root (in-list roots)))
(values (hash-ref root 'id) (title->slug (submap-title root))))) (values (hash-ref root 'id) (title->slug (submap-title root))))))
(hash-set (hash-set
document document
'items 'items
(for/list ((item (in-list (json-list document 'items)))) (for/list ((item (in-list (json-list document 'items))))
(define slug (hash-ref slugs (hash-ref item 'id #f) #f)) (let ((slug (hash-ref slugs (hash-ref item 'id #f) #f)))
(if slug (if slug
(hash-set (hash-set item 'cmapSlug slug) 'separateMap #t) (hash-set (hash-set item 'cmapSlug slug) 'separateMap #t)
item)))) item))))))
(define (load-parent-rows connection [lock? #f]) (define (load-parent-rows connection [lock? #f])
(query-rows (query-rows
@@ -98,50 +98,50 @@
(and row (member (vector-ref row 3) replaceable-authors))) (and row (member (vector-ref row 3) replaceable-authors)))
(define (check-child! connection parent-slug root [lock? #f]) (define (check-child! connection parent-slug root [lock? #f])
(define slug (title->slug (submap-title root))) (let* ((slug (title->slug (submap-title root)))
(define row (existing-child connection slug lock?)) (row (existing-child connection slug lock?)))
(when (and row (not (replaceable-child? row))) (when (and row (not (replaceable-child? row)))
(error 'migrate-cmap-subpages (error 'migrate-cmap-subpages
"target CMap ~a already exists and was not created by the earlier migration" "target CMap ~a already exists and was not created by the earlier migration"
slug)) slug))
(hash 'slug slug (hash 'slug slug
'title (submap-title root) 'title (submap-title root)
'rootId (hash-ref root 'id) 'rootId (hash-ref root 'id)
'sourceSlug parent-slug 'sourceSlug parent-slug
'existing row)) 'existing row)))
(define (plans-for-row connection row [lock? #f]) (define (plans-for-row connection row [lock? #f])
(define document (parse-document (vector-ref row 3))) (let* ((document (parse-document (vector-ref row 3)))
(define roots (filter legacy-submap? (json-list document 'items))) (roots (filter legacy-submap? (json-list document 'items)))
(define children (children
(for/list ((root (in-list roots))) (for/list ((root (in-list roots)))
(check-child! connection (vector-ref row 1) root lock?))) (check-child! connection (vector-ref row 1) root lock?))))
(values children (link-parent-document document roots))) (values children (link-parent-document document roots))))
(define (report-plan connection) (define (report-plan connection)
(define total 0) (let ((total 0))
(for ((row (in-list (load-parent-rows connection)))) (for ((row (in-list (load-parent-rows connection))))
(define-values (children ignored-parent) (plans-for-row connection row)) (let-values (((children ignored-parent) (plans-for-row connection row)))
(printf "Parent ~a (~a): ~a shared submap view(s)\n" (printf "Parent ~a (~a): ~a shared submap view(s)\n"
(vector-ref row 1) (vector-ref row 2) (length children)) (vector-ref row 1) (vector-ref row 2) (length children))
(for ((child (in-list children))) (for ((child (in-list children)))
(set! total (add1 total)) (set! total (add1 total))
(printf " ~a -> ~a (~a)\n" (printf " ~a -> ~a (~a)\n"
(hash-ref child 'title) (hash-ref child 'title)
(hash-ref child 'slug) (hash-ref child 'slug)
(if (hash-ref child 'existing) "replace earlier migration result" "create")))) (if (hash-ref child 'existing) "replace earlier migration result" "create")))))
(printf "Total: ~a shared view(s). No data changed.\n" total) (printf "Total: ~a shared view(s). No data changed.\n" total)
total) total))
(define (write-child! connection child now) (define (write-child! connection child now)
(define document-text (let ((document-text
(jsexpr->string (jsexpr->string
(derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId)))) (derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId))))
(define existing (hash-ref child 'existing)) (existing (hash-ref child 'existing)))
(if existing (if existing
(let* ((map-id (vector-ref existing 0)) (let* ((map-id (vector-ref existing 0))
(title (vector-ref existing 1)) (title (vector-ref existing 1))
(next-version (add1 (vector-ref existing 2)))) (next-version (add1 (vector-ref existing 2))))
(query-exec (query-exec
connection connection
#<<SQL #<<SQL
@@ -178,42 +178,42 @@ INSERT INTO concept_map_versions
VALUES ($1,1,$2,$3::text::jsonb,$4,'shared-view-migration', VALUES ($1,1,$2,$3::text::jsonb,$4,'shared-view-migration',
'Created canonical shared sub-CMap view',$5) 'Created canonical shared sub-CMap view',$5)
SQL 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) (define (apply-migration! connection)
(call-with-transaction (call-with-transaction
connection connection
(lambda () (λ ()
(define now (current-seconds)) (let ((now (current-seconds))
(define total 0) (total 0))
(for ((row (in-list (load-parent-rows connection #t)))) (for ((row (in-list (load-parent-rows connection #t))))
(define-values (children parent-document) (plans-for-row connection row #t)) (let-values (((children parent-document) (plans-for-row connection row #t)))
(for ((child (in-list children))) (for ((child (in-list children)))
(write-child! connection child now) (write-child! connection child now)
(set! total (add1 total))) (set! total (add1 total)))
(unless (null? children) (unless (null? children)
(define map-id (vector-ref row 0)) (let ((map-id (vector-ref row 0))
(define next-version (add1 (vector-ref row 4))) (next-version (add1 (vector-ref row 4)))
(define parent-text (jsexpr->string parent-document)) (parent-text (jsexpr->string parent-document)))
(query-exec (query-exec
connection connection
#<<SQL #<<SQL
UPDATE concept_maps UPDATE concept_maps
SET document=$1::text::jsonb, current_version=$2, updated_at=$3, updated_by=$4 SET document=$1::text::jsonb, current_version=$2, updated_at=$3, updated_by=$4
WHERE id=$5 WHERE id=$5
SQL SQL
parent-text next-version now migration-author map-id) parent-text next-version now migration-author map-id)
(query-exec (query-exec
connection connection
#<<SQL #<<SQL
INSERT INTO concept_map_versions INSERT INTO concept_map_versions
(concept_map_id,version,title,document,author,action,summary,created_at) (concept_map_id,version,title,document,author,action,summary,created_at)
VALUES ($1,$2,$3,$4::text::jsonb,$5,'shared-view-migration', VALUES ($1,$2,$3,$4::text::jsonb,$5,'shared-view-migration',
'Linked internal sub-CMaps to standalone shared views without moving graph data',$6) 'Linked internal sub-CMaps to standalone shared views without moving graph data',$6)
SQL SQL
map-id next-version (vector-ref row 2) parent-text migration-author now))) 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) (printf "Migrated ~a submap(s) to shared stored views in one transaction.\n" total)
total))) total))))
(module+ main (module+ main
(define config (default-wiki-config)) (define config (default-wiki-config))
@@ -231,5 +231,5 @@ SQL
(set! apply? #t))) (set! apply? #t)))
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (connection) (λ (connection)
(if apply? (apply-migration! connection) (report-plan 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)) (format "/uploads/~a/~a" reference stored-name))
(define (page-references db page-id) (define (page-references db page-id)
(define current (let* ((current
(query-row db (query-row db
"SELECT namespace, slug FROM pages WHERE id = $1" "SELECT namespace, slug FROM pages WHERE id = $1"
page-id)) page-id))
(define references (references
(list (if (string=? (vector-ref current 0) "") (list (if (string=? (vector-ref current 0) "")
(vector-ref current 1) (vector-ref current 1)
(string-append (vector-ref current 0) ":" (vector-ref current 1))))) (string-append (vector-ref current 0) ":" (vector-ref current 1)))))
(define aliases-available? (aliases-available?
(query-value db "SELECT to_regclass('page_aliases') IS NOT NULL")) (query-value db "SELECT to_regclass('page_aliases') IS NOT NULL")))
(when aliases-available? (when aliases-available?
(for ((row (in-list (for ((row (in-list
(query-rows db (query-rows db
"SELECT namespace, slug FROM page_aliases WHERE page_id = $1 ORDER BY id" "SELECT namespace, slug FROM page_aliases WHERE page_id = $1 ORDER BY id"
page-id)))) page-id))))
(define reference (let ((reference
(if (string=? (vector-ref row 0) "") (if (string=? (vector-ref row 0) "")
(vector-ref row 1) (vector-ref row 1)
(string-append (vector-ref row 0) ":" (vector-ref row 1)))) (string-append (vector-ref row 0) ":" (vector-ref row 1)))))
(set! references (cons reference references)))) (set! references (cons reference references)))))
references) references))
(define (record-references! db page-id page-version-id markdown current? referenced-at) (define (record-references! db page-id page-version-id markdown current? referenced-at)
(for ((row (in-list (attachment-rows db)))) (for ((row (in-list (attachment-rows db))))
(define attachment-id (vector-ref row 0)) (let ((attachment-id (vector-ref row 0))
(define owner-page-id (vector-ref row 1)) (owner-page-id (vector-ref row 1))
(define stored-name (vector-ref row 2)) (stored-name (vector-ref row 2))
(define found? #f) (found? #f))
(for ((reference (in-list (page-references db owner-page-id)))) (for ((reference (in-list (page-references db owner-page-id))))
(when (string-contains? markdown (attachment-url reference stored-name)) (when (string-contains? markdown (attachment-url reference stored-name))
(set! found? #t))) (set! found? #t)))
(when found? (when found?
(query-exec db (query-exec db
#<<SQL #<<SQL
INSERT INTO attachment_references INSERT INTO attachment_references
(attachment_id, page_id, page_version_id, current_reference, referenced_at) (attachment_id, page_id, page_version_id, current_reference, referenced_at)
VALUES ($1, $2, $3, $4, $5) VALUES ($1, $2, $3, $4, $5)
SQL SQL
attachment-id attachment-id
page-id page-id
page-version-id page-version-id
current? current?
referenced-at)))) referenced-at)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions ;; Provided functions
private/auth.rkt
+187 -181
View File
@@ -56,10 +56,10 @@
(define (bytes->hex value) (define (bytes->hex value)
(apply string-append (apply string-append
(for/list ([byte (in-bytes value)]) (for/list ([byte (in-bytes value)])
(define hex (number->string byte 16)) (let ((hex (number->string byte 16)))
(if (= (string-length hex) 1) (if (= (string-length hex) 1)
(string-append "0" hex) (string-append "0" hex)
hex)))) hex)))))
(define (random-token [size 32]) (define (random-token [size 32])
(bytes->hex (crypto-random-bytes size))) (bytes->hex (crypto-random-bytes size)))
@@ -88,8 +88,8 @@
(if (sql-null? value) #f value)) (if (sql-null? value) #f value))
(define (normalized-email email) (define (normalized-email email)
(define value (string-downcase (string-trim (or email "")))) (let ((value (string-downcase (string-trim (or email "")))))
(if (string=? value "") sql-null value)) (if (string=? value "") sql-null value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Authenticate an enabled wiki user. ; goal : Authenticate an enabled wiki user.
@@ -101,22 +101,22 @@
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define row (let ((row
(query-maybe-row (query-maybe-row
db db
"SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1" "SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1"
username)) username)))
(cond (cond
((not row) #f) ((not row) #f)
((not (vector-ref row 5)) #f) ((not (vector-ref row 5)) #f)
((not (password-valid? password (vector-ref row 6))) #f) ((not (password-valid? password (vector-ref row 6))) #f)
(else (else
(wiki-user (vector-ref row 0) (wiki-user (vector-ref row 0)
(vector-ref row 1) (vector-ref row 1)
(vector-ref row 2) (vector-ref row 2)
(sql-null->false (vector-ref row 3)) (sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4)) (string->symbol (vector-ref row 4))
#t)))))) #t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a login session for a user. ; goal : Create a login session for a user.
@@ -125,21 +125,21 @@
; result : A wiki-session containing the client session token. ; result : A wiki-session containing the client session token.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-session! config user) (define (create-session! config user)
(define token (random-token)) (let* ((token (random-token))
(define csrf-token (random-token 24)) (csrf-token (random-token 24))
(define now (current-seconds)) (now (current-seconds))
(define expires-at (+ now (wiki-config-session-seconds config))) (expires-at (+ now (wiki-config-session-seconds config))))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(query-exec db (query-exec db
"INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)" "INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)"
(token-hash token) (token-hash token)
(wiki-user-id user) (wiki-user-id user)
csrf-token csrf-token
now now
expires-at))) expires-at)))
(wiki-session user csrf-token expires-at token)) (wiki-session user csrf-token expires-at token)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Delete a login session. ; goal : Delete a login session.
@@ -157,13 +157,13 @@
(token-hash token)))))) (token-hash token))))))
(define (session-cookie-token req) (define (session-cookie-token req)
(define cookie (let ((cookie
(findf (λ (candidate) (findf (λ (candidate)
(string=? (client-cookie-name candidate) "racket-wiki-session")) (string=? (client-cookie-name candidate) "racket-wiki-session"))
(request-cookies req))) (request-cookies req))))
(if cookie (if cookie
(client-cookie-value cookie) (client-cookie-value cookie)
#f)) #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve an authenticated session from a request cookie. ; 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. ; result : A non-expired wiki-session for an enabled user, or #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (session-from-request config req) (define (session-from-request config req)
(define token (session-cookie-token req)) (let ((token (session-cookie-token req)))
(if token (if token
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define row (let ((row
(query-maybe-row (query-maybe-row
db db
#<<SQL #<<SQL
SELECT u.id, u.username, u.display_name, u.email, u.role, u.enabled, SELECT u.id, u.username, u.display_name, u.email, u.role, u.enabled,
s.csrf_token, s.expires_at s.csrf_token, s.expires_at
FROM sessions s FROM sessions s
JOIN users u ON u.id = s.user_id JOIN users u ON u.id = s.user_id
WHERE s.token_hash = $1 AND s.expires_at > $2 AND u.enabled = TRUE WHERE s.token_hash = $1 AND s.expires_at > $2 AND u.enabled = TRUE
SQL SQL
(token-hash token) (token-hash token)
(current-seconds))) (current-seconds))))
(if row (if row
(wiki-session (wiki-session
(wiki-user (vector-ref row 0) (wiki-user (vector-ref row 0)
(vector-ref row 1) (vector-ref row 1)
(vector-ref row 2) (vector-ref row 2)
(sql-null->false (vector-ref row 3)) (sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4)) (string->symbol (vector-ref row 4))
(vector-ref row 5)) (vector-ref row 5))
(vector-ref row 6) (vector-ref row 6)
(vector-ref row 7) (vector-ref row 7)
token) token)
#f))) #f))))
#f)) #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Validate a CSRF token for a session. ; goal : Validate a CSRF token for a session.
@@ -249,23 +249,23 @@ SQL
; result : void. ; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-user! config username display-name password role status [email #f]) (define (create-user! config username display-name password role status [email #f])
(define now (current-seconds)) (let ((now (current-seconds))
(define enabled (eq? status 'enabled)) (enabled (eq? status 'enabled))
(define hash (password-hash password)) (hash (password-hash password)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(query-exec (query-exec
db 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)" "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 username
display-name display-name
(normalized-email email) (normalized-email email)
hash hash
(symbol->string role) (symbol->string role)
enabled enabled
now now
now)))) now)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create or reset a wiki user by username. ; goal : Create or reset a wiki user by username.
@@ -274,15 +274,15 @@ SQL
; result : void. ; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (upsert-user! config username display-name password role status) (define (upsert-user! config username display-name password role status)
(define now (current-seconds)) (let ((now (current-seconds))
(define enabled (eq? status 'enabled)) (enabled (eq? status 'enabled))
(define hash (password-hash password)) (hash (password-hash password)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(query-exec (query-exec
db db
#<<SQL #<<SQL
INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at) INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at)
VALUES ($1, $2, $3, $4, $5, $6, $7) VALUES ($1, $2, $3, $4, $5, $6, $7)
ON CONFLICT(username) DO UPDATE SET ON CONFLICT(username) DO UPDATE SET
@@ -292,7 +292,7 @@ ON CONFLICT(username) DO UPDATE SET
enabled = excluded.enabled, enabled = excluded.enabled,
updated_at = excluded.updated_at updated_at = excluded.updated_at
SQL 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. ; goal : Update a wiki user.
@@ -301,29 +301,29 @@ SQL
; result : void. ; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-user! config id display-name role status [password #f] [email #f]) (define (update-user! config id display-name role status [password #f] [email #f])
(define enabled (eq? status 'enabled)) (let ((enabled (eq? status 'enabled))
(define now (current-seconds)) (now (current-seconds)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(if (and password (not (string=? password ""))) (if (and password (not (string=? password "")))
(query-exec db (query-exec db
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, password_hash = $5, updated_at = $6 WHERE id = $7" "UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, password_hash = $5, updated_at = $6 WHERE id = $7"
display-name display-name
(normalized-email email) (normalized-email email)
(symbol->string role) (symbol->string role)
enabled enabled
(password-hash password) (password-hash password)
now now
id) id)
(query-exec db (query-exec db
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, updated_at = $5 WHERE id = $6" "UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, updated_at = $5 WHERE id = $6"
display-name display-name
(normalized-email email) (normalized-email email)
(symbol->string role) (symbol->string role)
enabled enabled
now now
id))))) id))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Update the authenticated user's profile and optionally password. ; goal : Update the authenticated user's profile and optionally password.
@@ -332,31 +332,31 @@ SQL
; result : void; an invalid current password raises an exception. ; 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 (update-own-profile! config user-id session-token display-name email current-password new-password)
(define change-password? (let ((change-password?
(and new-password (not (string=? new-password "")))) (and new-password (not (string=? new-password "")))))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(call-with-transaction (call-with-transaction
db db
(λ () (λ ()
(when change-password? (when change-password?
(define stored-hash (let ((stored-hash
(query-maybe-value db "SELECT password_hash FROM users WHERE id = $1" user-id)) (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)) (unless (and stored-hash current-password (password-valid? current-password stored-hash))
(error 'update-own-profile! "The current password is incorrect"))) (error 'update-own-profile! "The current password is incorrect"))))
(if change-password? (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 (query-exec db
"UPDATE users SET display_name = $1, email = $2, password_hash = $3, updated_at = $4 WHERE id = $5" "DELETE FROM sessions WHERE user_id = $1 AND token_hash <> $2"
display-name (normalized-email email) (password-hash new-password) (current-seconds) user-id) user-id
(query-exec db (token-hash session-token)))))))))
"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))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a short-lived one-time password-reset token for an account. ; 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. ; 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 (request-password-reset! config identity [lifetime 3600] [maximum-per-hour 2])
(define token (random-token)) (let ((token (random-token))
(define now (current-seconds)) (now (current-seconds)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(call-with-transaction (call-with-transaction
db db
(λ () (λ ()
(query-exec db "DELETE FROM password_reset_tokens WHERE created_at <= $1" (- now 3600)) (query-exec db "DELETE FROM password_reset_tokens WHERE created_at <= $1" (- now 3600))
(define row (let ((row
(query-maybe-row db (query-maybe-row db
"SELECT id, email FROM users WHERE enabled = TRUE AND (lower(username) = lower($1) OR lower(email) = lower($1)) FOR UPDATE" "SELECT id, email FROM users WHERE enabled = TRUE AND (lower(username) = lower($1) OR lower(email) = lower($1)) FOR UPDATE"
(string-trim identity))) (string-trim identity))))
(if (and row (not (sql-null? (vector-ref row 1)))) (if (and row (not (sql-null? (vector-ref row 1))))
(let ((recent-count (let ((recent-count
(query-value db (query-value db
"SELECT COUNT(*) FROM password_reset_tokens WHERE user_id = $1 AND created_at > $2" "SELECT COUNT(*) FROM password_reset_tokens WHERE user_id = $1 AND created_at > $2"
(vector-ref row 0) (vector-ref row 0)
(- now 3600)))) (- now 3600))))
(if (>= recent-count maximum-per-hour) (if (>= recent-count maximum-per-hour)
#f #f
(begin (begin
(query-exec db (query-exec db
"INSERT INTO password_reset_tokens(token_hash, user_id, created_at, expires_at) VALUES ($1, $2, $3, $4)" "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)) (token-hash token) (vector-ref row 0) now (+ now lifetime))
(cons token (vector-ref row 1))))) (cons token (vector-ref row 1)))))
#f)))))) #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) (define (cancel-password-reset! config token)
(call-with-wiki-database (call-with-wiki-database
config config
@@ -412,18 +418,18 @@ SQL
(call-with-transaction (call-with-transaction
db db
(λ () (λ ()
(define now (current-seconds)) (let* ((now (current-seconds))
(define user-id (user-id
(query-maybe-value db (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" "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)) (token-hash token) now)))
(if user-id (if user-id
(begin (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 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 "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) (query-exec db "DELETE FROM sessions WHERE user_id = $1" user-id)
#t) #t)
#f)))))) #f)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Delete a wiki user. ; goal : Delete a wiki user.
private/cmap-storage.rkt
+3 -3
View File
@@ -830,7 +830,7 @@ SQL
(and version-number (and version-number
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (db) (λ (db)
(and (and
(query-maybe-value (query-maybe-value
db db
@@ -962,13 +962,13 @@ SQL
'externalUrl) 'externalUrl)
"https://example.com/path") "https://example.com/path")
(check-exn exn:fail? (check-exn exn:fail?
(lambda () (λ ()
(concept-content (concept-content
(hash 'id concept-a (hash 'id concept-a
'label "Unsafe concept" 'label "Unsafe concept"
'externalUrl "javascript:alert(1)")))) 'externalUrl "javascript:alert(1)"))))
(check-exn exn:fail? (check-exn exn:fail?
(lambda () (λ ()
(concept-map-storage-document (concept-map-storage-document
(hash 'concepts (list (hash 'id "legacy:map:concept-1")) (hash 'concepts (list (hash 'id "legacy:map:concept-1"))
'items '()))))) 'items '())))))
private/cmap-styles.rkt
+72 -49
View File
@@ -97,59 +97,82 @@
(define (normalize-cmap-styles styles [who 'cmap-styles]) (define (normalize-cmap-styles styles [who 'cmap-styles])
(unless (and (list? styles) (<= 1 (length styles) maximum-style-count)) (unless (and (list? styles) (<= 1 (length styles) maximum-style-count))
(error who "styles must contain between 1 and ~a entries" maximum-style-count)) (error who "styles must contain between 1 and ~a entries" maximum-style-count))
(define seen (make-hash)) (let* ((seen (make-hash))
(define normalized (normalized
(for/list ([style (in-list styles)]) (for/list ([style (in-list styles)])
(unless (hash? style) (error who "each style must be an object")) (unless (hash? style) (error who "each style must be an object"))
(define id (required-string who (hash-ref style 'id #f) "style id" 120)) (let* ((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")) (name (and (string? (hash-ref style 'name #f))
(when (hash-ref seen id #f) (error who "duplicate style id: ~a" id)) (required-string who
(hash-set! seen id #t) (hash-ref style 'name)
(define name (and (string? (hash-ref style 'name #f)) "style name"
(required-string who (hash-ref style 'name) "style name" maximum-style-name-length))) maximum-style-name-length)))
(define name-key (and (string? (hash-ref style 'nameKey #f)) (name-key
(string->symbol (required-string who (hash-ref style 'nameKey) "style name key" 40)))) (and (string? (hash-ref style 'nameKey #f))
(unless (or name (member name-key permitted-name-keys)) (string->symbol
(error who "a style needs a name")) (required-string who
(hash 'id id (hash-ref style 'nameKey)
(if (member name-key permitted-name-keys) 'nameKey 'name) "style name key"
(if (member name-key permitted-name-keys) (symbol->string name-key) name) 40)))))
'protected (string=? id "default") (unless (regexp-match? #px"^[A-Za-z0-9_-]+$" id)
'values (normalize-style-values who (hash-ref style 'values #f))))) (error who "invalid style id"))
(unless (hash-ref seen "default" #f) (error who "the default style is required")) (when (hash-ref seen id #f)
normalized) (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) (define (read-cmap-styles config)
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (db) (λ (db)
(define stored (let ((stored
(query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key)) (query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key)))
(if stored (if stored
(normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles) (normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles)
(let ([encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))]) (let ((encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))))
(query-exec (query-exec
db db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING" "INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING"
setting-key encoded (current-seconds)) setting-key encoded (current-seconds))
(normalize-cmap-styles (normalize-cmap-styles
(string->jsexpr (string->jsexpr
(query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key)) (query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
'read-cmap-styles)))))) '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 (save-cmap-styles! config styles)
(define normalized (normalize-cmap-styles styles 'save-cmap-styles!)) (let* ((normalized (normalize-cmap-styles styles 'save-cmap-styles!))
(define encoded (jsexpr->string normalized)) (encoded (jsexpr->string normalized)))
(when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024)) (when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024))
(error 'save-cmap-styles! "style data is too large")) (error 'save-cmap-styles! "style data is too large"))
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (db) (λ (db)
(query-exec (query-exec
db 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" "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)))) setting-key encoded (current-seconds))))
normalized) normalized))
(module+ test (module+ test
(require rackunit) (require rackunit)
@@ -164,8 +187,8 @@
(list (hash 'id "default" 'nameKey "style-default" 'values values)))) (list (hash 'id "default" 'nameKey "style-default" 'values values))))
(check-equal? (hash-ref (hash-ref (first normalized) 'values) 'backgroundColor) "#fff4cf") (check-equal? (hash-ref (hash-ref (first normalized) 'values) 'backgroundColor) "#fff4cf")
(check-equal? (length (normalize-cmap-styles initial-cmap-styles)) 5) (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? (check-exn exn:fail?
(lambda () (λ ()
(normalize-cmap-styles (normalize-cmap-styles
(list (hash 'id "custom" 'name "Custom" 'values values)))))) (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 ;; Concept ids are stored as plain UUID strings. Validation accepts uppercase
;; input, while normalization always produces the canonical lowercase form. ;; 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) (define (concept-id? value)
(uuid-string? 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) (define (normalize-concept-id value)
(cond (cond
[(uuid-string? value) (string-downcase value)] [(uuid-string? value) (string-downcase value)]
[(and (string? value) [(and (string? value)
(regexp-match prefixed-uuid-concept-id-pattern value)) (regexp-match prefixed-uuid-concept-id-pattern value))
=> (lambda (match) (string-downcase (cadr match)))] => (λ (match) (string-downcase (cadr match)))]
[else #f])) [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) (define (new-concept-id)
(uuid-string)) (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) (define (normalized-or-new-concept-id value)
(or (normalize-concept-id value) (or (normalize-concept-id value)
(new-concept-id))) (new-concept-id)))
private/config.rkt
+53 -11
View File
@@ -43,35 +43,77 @@
#:site-title [site-title "Racket Wiki"] #:site-title [site-title "Racket Wiki"]
#:session-seconds [session-seconds (* 12 60 60)] #:session-seconds [session-seconds (* 12 60 60)]
#:language [language "en"]) #:language [language "en"])
(define normalized-listen-ip (let ((normalized-listen-ip
(if (equal? listen-ip "*") (if (equal? listen-ip "*")
#f #f
listen-ip)) listen-ip)))
(wiki-config (path->complete-path data-dir) (wiki-config (path->complete-path data-dir)
port port
normalized-listen-ip normalized-listen-ip
secure-cookie? secure-cookie?
site-title site-title
session-seconds session-seconds
language)) 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) (define (default-wiki-config)
(make-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) (define (uploads-directory config)
(build-path (wiki-config-data-dir config) "uploads")) (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) (define (deleted-directory config)
(build-path (wiki-config-data-dir config) "deleted")) (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) (define (data-static-directory config)
(build-path (wiki-config-data-dir config) "static")) (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) (define (vendor-directory config)
(build-path (data-static-directory config) "vendor")) (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) (define (database-config-path config)
(build-path (wiki-config-data-dir config) "database.rktd")) (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) (define (language-config-path config)
(build-path (wiki-config-data-dir config) "language.rktd")) (build-path (wiki-config-data-dir config) "language.rktd"))
private/database.rkt
+65 -29
View File
@@ -26,6 +26,12 @@
;; Supporting functions ;; 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) (define (database-settings-exist? config)
(file-exists? (database-config-path config))) (file-exists? (database-config-path config)))
@@ -45,12 +51,24 @@
(hash-ref value 'password "") (hash-ref value 'password "")
(hash-ref value 'ssl 'no))) (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) (define (read-database-settings config)
(and (database-settings-exist? config) (and (database-settings-exist? config)
(call-with-input-file (database-config-path config) (call-with-input-file (database-config-path config)
(λ (in) (λ (in)
(datum->settings (read 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) (define (write-database-settings! config settings)
(make-directory* (wiki-config-data-dir config)) (make-directory* (wiki-config-data-dir config))
(call-with-output-file (database-config-path config) (call-with-output-file (database-config-path config)
@@ -63,24 +81,30 @@
(void)) (void))
(define (connect settings) (define (connect settings)
(define password (let ((password
(if (string=? (database-settings-password settings) "") (if (string=? (database-settings-password settings) "")
#f #f
(database-settings-password settings))) (database-settings-password settings))))
(postgresql-connect #:server (database-settings-server settings) (postgresql-connect #:server (database-settings-server settings)
#:port (database-settings-port settings) #:port (database-settings-port settings)
#:database (database-settings-database settings) #:database (database-settings-database settings)
#:user (database-settings-user settings) #:user (database-settings-user settings)
#:password password #:password password
#:ssl (database-settings-ssl settings))) #: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 (test-database-settings! settings)
(define db (connect settings)) (let ((db (connect settings)))
(dynamic-wind (dynamic-wind
void void
(λ () (query-value db "SELECT 1")) (λ () (query-value db "SELECT 1"))
(λ () (disconnect db))) (λ () (disconnect db)))
(void)) (void)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Run a procedure with a fresh PostgreSQL connection. ; goal : Run a procedure with a fresh PostgreSQL connection.
@@ -89,26 +113,32 @@
; result : The value returned by proc. ; result : The value returned by proc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (call-with-wiki-database config proc) (define (call-with-wiki-database config proc)
(define settings (read-database-settings config)) (let ((settings (read-database-settings config)))
(unless settings (unless settings
(error 'call-with-wiki-database "PostgreSQL is not configured")) (error 'call-with-wiki-database "PostgreSQL is not configured"))
(define db (connect settings)) (let ((db (connect settings)))
(dynamic-wind (dynamic-wind
void void
(λ () (proc db)) (λ () (proc db))
(λ () (disconnect db)))) (λ () (disconnect db))))))
(define (initialize-on-connection! db config) (define (initialize-on-connection! db config)
(migrate-database! db config) (migrate-database! db config)
(query-exec db "DELETE FROM sessions WHERE expires_at <= $1" (current-seconds)) (query-exec db "DELETE FROM sessions WHERE expires_at <= $1" (current-seconds))
(void)) (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 (initialize-database-with-settings! settings config)
(define db (connect settings)) (let ((db (connect settings)))
(dynamic-wind (dynamic-wind
void void
(λ () (initialize-on-connection! db config)) (λ () (initialize-on-connection! db config))
(λ () (disconnect db)))) (λ () (disconnect db)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Initialize the PostgreSQL schema used by racket-wiki. ; goal : Initialize the PostgreSQL schema used by racket-wiki.
@@ -122,6 +152,12 @@
(λ (db) (λ (db)
(initialize-on-connection! db config)))) (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) (define (database-ready? config)
(and (database-settings-exist? config) (and (database-settings-exist? config)
(with-handlers ((exn:fail? (λ (_e) #f))) (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. ; result : The decoded JSON value, or an empty hash for an empty body.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-json req) (define (request-json req)
(define body (request-post-data/raw req)) (let ((body (request-post-data/raw req)))
(if body (if body
(bytes->jsexpr body) (bytes->jsexpr body)
(hash))) (hash))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read a request header as UTF-8 text. ; goal : Read a request header as UTF-8 text.
@@ -94,11 +94,11 @@
; result : The header value as a string, or #f when absent. ; result : The header value as a string, or #f when absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-header/string req name) (define (request-header/string req name)
(define found (let ((found
(headers-assq* (string->bytes/utf-8 name) (headers-assq* (string->bytes/utf-8 name)
(request-headers/raw req))) (request-headers/raw req))))
(and found (and found
(bytes->string/utf-8 (header-value found)))) (bytes->string/utf-8 (header-value found)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create an HTTP response containing bytes. ; goal : Create an HTTP response containing bytes.
@@ -121,12 +121,12 @@
; result : A MIME byte string; application/octet-stream when the extension is unknown. ; result : A MIME byte string; application/octet-stream when the extension is unknown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (extension->mime filename) (define (extension->mime filename)
(define lower (string-downcase filename)) (let ((lower (string-downcase filename)))
(cond (cond
((regexp-match? #px"[.]png$" lower) #"image/png") ((regexp-match? #px"[.]png$" lower) #"image/png")
((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg") ((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg")
((regexp-match? #px"[.]gif$" lower) #"image/gif") ((regexp-match? #px"[.]gif$" lower) #"image/gif")
((regexp-match? #px"[.]webp$" lower) #"image/webp") ((regexp-match? #px"[.]webp$" lower) #"image/webp")
((regexp-match? #px"[.]pdf$" lower) #"application/pdf") ((regexp-match? #px"[.]pdf$" lower) #"application/pdf")
((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8") ((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8")
(else #"application/octet-stream"))) (else #"application/octet-stream"))))
private/mail.rkt
+155 -140
View File
@@ -18,10 +18,10 @@
send-password-reset-mail!) send-password-reset-mail!)
(define (environment-value name) (define (environment-value name)
(define value (getenv name)) (let ((value (getenv name)))
(and value (and value
(not (string=? (string-trim value) "")) (not (string=? (string-trim value) ""))
(string-trim value))) (string-trim value))))
(define (safe-header-value value) (define (safe-header-value value)
(regexp-replace* #px"[\r\n]+" value " ")) (regexp-replace* #px"[\r\n]+" value " "))
@@ -33,26 +33,26 @@
; result : An encoder accepted by smtp-send-message. ; result : An encoder accepted by smtp-send-message.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-starttls-encoder host accept-untrusted-certificates?) (define (make-starttls-encoder host accept-untrusted-certificates?)
(define context (let ((context
(if accept-untrusted-certificates? (if accept-untrusted-certificates?
(ssl-make-client-context 'auto) (ssl-make-client-context 'auto)
(ssl-secure-client-context))) (ssl-secure-client-context))))
(λ (input-port output-port (λ (input-port output-port
#:mode mode #:mode mode
#:encrypt _protocol #:encrypt _protocol
#:close-original? close-original?) #:close-original? close-original?)
(if accept-untrusted-certificates? (if accept-untrusted-certificates?
(ports->ssl-ports input-port (ports->ssl-ports input-port
output-port output-port
#:mode mode #:mode mode
#:context context #:context context
#:close-original? close-original?) #:close-original? close-original?)
(ports->ssl-ports input-port (ports->ssl-ports input-port
output-port output-port
#:mode mode #:mode mode
#:context context #:context context
#:hostname host #:hostname host
#:close-original? close-original?)))) #:close-original? close-original?)))))
(define setting-environment-names (define setting-environment-names
(hash "public-url" "RACKET_WIKI_PUBLIC_URL" (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.%'")))) (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)))))) (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 (password-reset-mail-settings config)
(define stored (database-mail-settings config)) (let ((stored (database-mail-settings config)))
(for/hash (((key environment-name) (in-hash setting-environment-names))) (for/hash (((key environment-name) (in-hash setting-environment-names)))
(define default (let ((default
(cond (cond
((string=? key "smtp-port") "587") ((string=? key "smtp-port") "587")
((string=? key "reset-limit") "2") ((string=? key "reset-limit") "2")
((string=? key "smtp-tls") "true") ((string=? key "smtp-tls") "true")
((string=? key "smtp-accept-untrusted-certificates") "false") ((string=? key "smtp-accept-untrusted-certificates") "false")
(else ""))) (else ""))))
(values key (or (hash-ref stored key #f) (values key (or (hash-ref stored key #f)
(environment-value environment-name) (environment-value environment-name)
default)))) 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) (define (save-password-reset-mail-settings! config settings)
(call-with-wiki-database (call-with-wiki-database
config config
@@ -94,88 +106,91 @@
db db
(λ () (λ ()
(for (((key _environment-name) (in-hash setting-environment-names))) (for (((key _environment-name) (in-hash setting-environment-names)))
(define supplied-value (hash-ref settings key "")) (let* ((supplied-value (hash-ref settings key ""))
(define value (value
(if (string=? key "smtp-password") (if (string=? key "smtp-password")
supplied-value supplied-value
(string-trim supplied-value))) (string-trim supplied-value))))
(unless (and (string=? key "smtp-password") (string=? value "")) (unless (and (string=? key "smtp-password") (string=? value ""))
(if (string=? value "") (if (string=? value "")
(query-exec db "DELETE FROM wiki_settings WHERE key = $1" (string-append "mail." key)) (query-exec db "DELETE FROM wiki_settings WHERE key = $1" (string-append "mail." key))
(query-exec 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" "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)))))))))) (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 (password-reset-mail-configured? config)
(define settings (password-reset-mail-settings config)) (let ((settings (password-reset-mail-settings config)))
(and (not (string=? (hash-ref settings "public-url") "")) (and (not (string=? (hash-ref settings "public-url") ""))
(not (string=? (hash-ref settings "smtp-host") "")) (not (string=? (hash-ref settings "smtp-host") ""))
(not (string=? (hash-ref settings "smtp-from") "")))) (not (string=? (hash-ref settings "smtp-from") "")))))
(define (settings-with-stored-password config supplied-settings) (define (settings-with-stored-password config supplied-settings)
(define stored-settings (password-reset-mail-settings config)) (let* ((stored-settings (password-reset-mail-settings config))
(define supplied-password (hash-ref supplied-settings "smtp-password" "")) (supplied-password (hash-ref supplied-settings "smtp-password" ""))
(define effective-password (effective-password
(if (string=? supplied-password "") (if (string=? supplied-password "")
(hash-ref stored-settings "smtp-password" "") (hash-ref stored-settings "smtp-password" "")
supplied-password)) supplied-password)))
(for/hash (((key _environment-name) (in-hash setting-environment-names))) (for/hash (((key _environment-name) (in-hash setting-environment-names)))
(define value (let ((value
(if (string=? key "smtp-password") (if (string=? key "smtp-password")
effective-password effective-password
(hash-ref supplied-settings key (hash-ref stored-settings key "")))) (hash-ref supplied-settings key (hash-ref stored-settings key "")))))
(values key value))) (values key value)))))
(define (send-mail-with-settings! settings recipient subject body-lines) (define (send-mail-with-settings! settings recipient subject body-lines)
(define host (string-trim (hash-ref settings "smtp-host" ""))) (let ((host (string-trim (hash-ref settings "smtp-host" "")))
(define from (safe-header-value (string-trim (hash-ref settings "smtp-from" "")))) (from (safe-header-value (string-trim (hash-ref settings "smtp-from" "")))))
(when (string=? host "") (when (string=? host "")
(error 'send-mail-with-settings! "SMTP server is required")) (error 'send-mail-with-settings! "SMTP server is required"))
(when (string=? from "") (when (string=? from "")
(error 'send-mail-with-settings! "Sender address is required")) (error 'send-mail-with-settings! "Sender address is required"))
(define configured-port (string->number (hash-ref settings "smtp-port" "587"))) (let* ((configured-port (string->number (hash-ref settings "smtp-port" "587")))
(define port (port
(if (and (exact-integer? configured-port) (<= 1 configured-port 65535)) (if (and (exact-integer? configured-port) (<= 1 configured-port 65535))
configured-port configured-port
587)) 587))
(define configured-user (hash-ref settings "smtp-user" "")) (configured-user (hash-ref settings "smtp-user" ""))
(define user (user (if (string=? configured-user "") #f configured-user))
(if (string=? configured-user "") #f configured-user)) (configured-password (hash-ref settings "smtp-password" ""))
(define configured-password (hash-ref settings "smtp-password" "")) (password (if (string=? configured-password "") #f configured-password))
(define password (starttls? (string-ci=? (hash-ref settings "smtp-tls" "true") "true"))
(if (string=? configured-password "") #f configured-password)) (accept-untrusted-certificates?
(define starttls? (string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true"))
(string-ci=? (hash-ref settings "smtp-tls" "true") "true")) (header
(define accept-untrusted-certificates? (string-append "From: " from "\r\n"
(string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true")) "To: " (safe-header-value recipient) "\r\n"
(define header "Subject: " (safe-header-value subject) "\r\n"
(string-append "From: " from "\r\n" "MIME-Version: 1.0\r\n"
"To: " (safe-header-value recipient) "\r\n" "Content-Type: text/plain; charset=UTF-8\r\n"
"Subject: " (safe-header-value subject) "\r\n" "\r\n"))
"MIME-Version: 1.0\r\n" (message
"Content-Type: text/plain; charset=UTF-8\r\n" (for/list ((line (in-list body-lines)))
"\r\n")) (string->bytes/utf-8 line))))
(define message (with-handlers ((exn:fail?
(for/list ((line (in-list body-lines))) (λ (exception)
(string->bytes/utf-8 line))) (let ((message (exn-message exception)))
(with-handlers ((exn:fail? (if (regexp-match? #px"certificate verify failed" message)
(λ (exception) (error 'send-mail-with-settings!
(define message (exn-message exception)) "TLS certificate verification failed; install a valid certificate or explicitly accept untrusted certificates for this trusted local SMTP server")
(if (regexp-match? #px"certificate verify failed" message) (raise exception))))))
(error 'send-mail-with-settings! (smtp-send-message host
"TLS certificate verification failed; install a valid certificate or explicitly accept untrusted certificates for this trusted local SMTP server") from
(raise exception))))) (list recipient)
(smtp-send-message host header
from message
(list recipient) #:port-no port
header #:auth-user user
message #:auth-passwd password
#:port-no port #:tls-encode (if starttls?
#:auth-user user (make-starttls-encoder host accept-untrusted-certificates?)
#:auth-passwd password #f))))))
#:tls-encode (if starttls?
(make-starttls-encoder host accept-untrusted-certificates?)
#f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Test supplied SMTP settings without storing them. ; goal : Test supplied SMTP settings without storing them.
@@ -184,17 +199,17 @@
; result : void. ; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-test-mail! config supplied-settings recipient) (define (send-test-mail! config supplied-settings recipient)
(define settings (let ((settings
(settings-with-stored-password config supplied-settings)) (settings-with-stored-password config supplied-settings)))
(send-mail-with-settings! (send-mail-with-settings!
settings settings
recipient recipient
(string-append (wiki-config-site-title config) " SMTP test") (string-append (wiki-config-site-title config) " SMTP test")
(list (string-append "This is a test message from " (list (string-append "This is a test message from "
(wiki-config-site-title config) (wiki-config-site-title config)
".") ".")
"" ""
"The SMTP server accepted the message using the settings from the administration form."))) "The SMTP server accepted the message using the settings from the administration form."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Send a one-time password-reset link through configured SMTP. ; goal : Send a one-time password-reset link through configured SMTP.
@@ -205,20 +220,20 @@
(define (send-password-reset-mail! config recipient token) (define (send-password-reset-mail! config recipient token)
(unless (password-reset-mail-configured? config) (unless (password-reset-mail-configured? config)
(error 'send-password-reset-mail! "Password-reset email is not configured")) (error 'send-password-reset-mail! "Password-reset email is not configured"))
(define settings (password-reset-mail-settings config)) (let* ((settings (password-reset-mail-settings config))
(define public-url (public-url
(string-trim (hash-ref settings "public-url") "/" #:right? #t)) (string-trim (hash-ref settings "public-url") "/" #:right? #t))
(define reset-url (reset-url
(string-append public-url "/reset-password?token=" token)) (string-append public-url "/reset-password?token=" token)))
(send-mail-with-settings! (send-mail-with-settings!
settings settings
recipient recipient
"Password reset" "Password reset"
(list (string-append "A password reset was requested for your account at " (list (string-append "A password reset was requested for your account at "
(wiki-config-site-title config) (wiki-config-site-title config)
".") ".")
"" ""
"Open this link within one hour:" "Open this link within one hour:"
reset-url reset-url
"" ""
"If you did not request this, you can ignore this email."))) "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 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) (define (database-schema-version db)
(if (table-exists? db "wiki_schema") (if (table-exists? db "wiki_schema")
(query-value db "SELECT COALESCE(MAX(version), 0) FROM wiki_schema") (query-value db "SELECT COALESCE(MAX(version), 0) FROM wiki_schema")
@@ -147,51 +153,51 @@ SQL
(install-schema-1! db)))) (install-schema-1! db))))
(define (legacy-mime-type stored-name) (define (legacy-mime-type stored-name)
(define lower (string-downcase stored-name)) (let ((lower (string-downcase stored-name)))
(cond (cond
((regexp-match? #px"[.]png$" lower) "image/png") ((regexp-match? #px"[.]png$" lower) "image/png")
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg") ((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
((regexp-match? #px"[.]gif$" lower) "image/gif") ((regexp-match? #px"[.]gif$" lower) "image/gif")
((regexp-match? #px"[.]webp$" lower) "image/webp") ((regexp-match? #px"[.]webp$" lower) "image/webp")
((regexp-match? #px"[.]pdf$" lower) "application/pdf") ((regexp-match? #px"[.]pdf$" lower) "application/pdf")
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8") ((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
(else "application/octet-stream"))) (else "application/octet-stream"))))
(define (migrate-1->2! db config) (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 mime_type TEXT")
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS content BYTEA") (query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS content BYTEA")
(define rows (let ((rows
(query-rows db (query-rows db
#<<SQL #<<SQL
SELECT a.id, p.slug, a.stored_name, a.content SELECT a.id, p.slug, a.stored_name, a.content
FROM attachments a FROM attachments a
JOIN pages p ON p.id = a.page_id JOIN pages p ON p.id = a.page_id
ORDER BY a.id ORDER BY a.id
SQL SQL
)) )))
(for ((row (in-list rows))) (for ((row (in-list rows)))
(define attachment-id (vector-ref row 0)) (let ((attachment-id (vector-ref row 0))
(define slug (vector-ref row 1)) (slug (vector-ref row 1))
(define stored-name (vector-ref row 2)) (stored-name (vector-ref row 2))
(define content (vector-ref row 3)) (content (vector-ref row 3)))
(unless (bytes? content) (unless (bytes? content)
(define path (build-path (uploads-directory config) slug stored-name)) (let ((path (build-path (uploads-directory config) slug stored-name)))
(unless (file-exists? path) (unless (file-exists? path)
(error 'migrate-database! (error 'migrate-database!
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a" "schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
stored-name stored-name
(path->string path))) (path->string path)))
(define bytes (file->bytes path)) (let ((bytes (file->bytes path)))
(query-exec db (query-exec db
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4" "UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
bytes bytes
(legacy-mime-type stored-name) (legacy-mime-type stored-name)
(bytes-length bytes) (bytes-length bytes)
attachment-id))) attachment-id))))))
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL") (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 mime_type SET NOT NULL")
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL") (query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
(record-schema-version! db 2)) (record-schema-version! db 2)))
(define (replace-page-todos! db page-id markdown) (define (replace-page-todos! db page-id markdown)
@@ -1092,10 +1098,10 @@ CREATE TEMP TABLE concept_uuid_rekey (
) ON COMMIT DROP ) ON COMMIT DROP
SQL SQL
) )
(define old-ids (let* ((old-ids
(query-list (query-list
db db
#<<SQL #<<SQL
WITH all_current_ids AS ( WITH all_current_ids AS (
SELECT id AS old_id FROM concept_definitions SELECT id AS old_id FROM concept_definitions
UNION UNION
@@ -1119,27 +1125,28 @@ FROM all_current_ids
WHERE nullif(old_id, '') IS NOT NULL WHERE nullif(old_id, '') IS NOT NULL
ORDER BY old_id ORDER BY old_id
SQL SQL
)) ))
;; Reserve every already canonical UUID before generating replacements, so a ;; Reserve every already canonical UUID before generating replacements,
;; random id can never collide with a UUID encountered later in the query. ;; so a random id can never collide with a UUID encountered later.
(define used-ids (make-hash)) (used-ids (make-hash)))
(for ([old-id (in-list old-ids)]) (for ([old-id (in-list old-ids)])
(define normalized (normalize-concept-id old-id)) (let ((normalized (normalize-concept-id old-id)))
(when normalized (hash-set! used-ids normalized #t))) (when normalized (hash-set! used-ids normalized #t))))
(define (fresh-unused-id) (letrec ((fresh-unused-id
(let loop () (λ ()
(define candidate (new-concept-id)) (let loop ()
(if (hash-has-key? used-ids candidate) (let ((candidate (new-concept-id)))
(loop) (if (hash-has-key? used-ids candidate)
(begin (loop)
(hash-set! used-ids candidate #t) (begin
candidate)))) (hash-set! used-ids candidate #t)
(for ([old-id (in-list old-ids)]) candidate)))))))
(query-exec (for ([old-id (in-list old-ids)])
db (query-exec
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)" db
old-id "INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
(or (normalize-concept-id old-id) (fresh-unused-id)))) old-id
(or (normalize-concept-id old-id) (fresh-unused-id)))))
(query-exec (query-exec
db db
#<<SQL #<<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}$') CHECK (id ~ '^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$')
SQL SQL
) )
(record-schema-version! db 21)) (record-schema-version! db 21)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Bring a racket-wiki PostgreSQL database to the current schema. ; goal : Bring a racket-wiki PostgreSQL database to the current schema.
@@ -1219,72 +1226,33 @@ SQL
db db
(λ () (λ ()
(recognize-or-install-schema-1! db) (recognize-or-install-schema-1! db)
(define version (database-schema-version db)) (let loop ((version (database-schema-version db)))
(when (< version 1) (cond
(error 'migrate-database! "unable to determine the existing wiki database schema")) ((< version 1)
(when (= version 1) (error 'migrate-database! "unable to determine the existing wiki database schema"))
(migrate-1->2! db config)) ((= version 1) (migrate-1->2! db config) (loop (database-schema-version db)))
(define after-attachments (database-schema-version db)) ((= version 2) (migrate-2->3! db) (loop (database-schema-version db)))
(when (= after-attachments 2) ((= version 3) (migrate-3->4! db) (loop (database-schema-version db)))
(migrate-2->3! db)) ((= version 4) (migrate-4->5! db) (loop (database-schema-version db)))
(define after-todos (database-schema-version db)) ((= version 5) (migrate-5->6! db) (loop (database-schema-version db)))
(when (= after-todos 3) ((= version 6) (migrate-6->7! db) (loop (database-schema-version db)))
(migrate-3->4! db)) ((= version 7) (migrate-7->8! db) (loop (database-schema-version db)))
(define after-bookmarks (database-schema-version db)) ((= version 8) (migrate-8->9! db) (loop (database-schema-version db)))
(when (= after-bookmarks 4) ((= version 9) (migrate-9->10! db) (loop (database-schema-version db)))
(migrate-4->5! db)) ((= version 10) (migrate-10->11! db) (loop (database-schema-version db)))
(define after-todo-reindex (database-schema-version db)) ((= version 11) (migrate-11->12! db) (loop (database-schema-version db)))
(when (= after-todo-reindex 5) ((= version 12) (migrate-12->13! db) (loop (database-schema-version db)))
(migrate-5->6! db)) ((= version 13) (migrate-13->14! db) (loop (database-schema-version db)))
(define after-attachment-references (database-schema-version db)) ((= version 14) (migrate-14->15! db) (loop (database-schema-version db)))
(when (= after-attachment-references 6) ((= version 15) (migrate-15->16! db) (loop (database-schema-version db)))
(migrate-6->7! db)) ((= version 16) (migrate-16->17! db) (loop (database-schema-version db)))
(define after-namespaces (database-schema-version db)) ((= version 17) (migrate-17->18! db) (loop (database-schema-version db)))
(when (= after-namespaces 7) ((= version 18) (migrate-18->19! db) (loop (database-schema-version db)))
(migrate-7->8! db)) ((= version 19) (migrate-19->20! db) (loop (database-schema-version db)))
(define after-page-aliases (database-schema-version db)) ((= version 20) (migrate-20->21! db) (loop (database-schema-version db)))
(when (= after-page-aliases 8) ((> version current-schema-version)
(migrate-8->9! db)) (error 'migrate-database!
(define after-concept-maps (database-schema-version db)) "database schema ~a is newer than this racket-wiki supports (~a)"
(when (= after-concept-maps 9) version
(migrate-9->10! db)) current-schema-version))
(define after-user-profiles (database-schema-version db)) (else version))))))
(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)))
private/people.rkt
+56 -32
View File
@@ -19,10 +19,16 @@
'name (vector-ref row 1) 'name (vector-ref row 1)
'active (vector-ref row 2))) '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]) (define (list-people config [include-inactive? #t])
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (db) (λ (db)
(for/list ((row (in-list (for/list ((row (in-list
(query-rows (query-rows
db db
@@ -35,45 +41,57 @@
(define (clean-person-name who name) (define (clean-person-name who name)
(unless (string? name) (unless (string? name)
(raise-argument-error who "string?" name)) (raise-argument-error who "string?" name))
(define clean (string-trim name)) (let ((clean (string-trim name)))
(when (or (string=? clean "") (> (string-length clean) 200)) (when (or (string=? clean "") (> (string-length clean) 200))
(error who "person name must contain between 1 and 200 characters")) (error who "person name must contain between 1 and 200 characters"))
clean) 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 (create-person! config name)
(define clean-name (clean-person-name 'create-person! name)) (let ((clean-name (clean-person-name 'create-person! name)))
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (db) (λ (db)
(define now (current-seconds)) (let ((now (current-seconds)))
(row->person (row->person
(query-row (query-row
db db
#<<SQL #<<SQL
INSERT INTO people(name, active, created_at, updated_at) INSERT INTO people(name, active, created_at, updated_at)
VALUES ($1, TRUE, $2, $2) VALUES ($1, TRUE, $2, $2)
ON CONFLICT (lower(name)) DO UPDATE ON CONFLICT (lower(name)) DO UPDATE
SET name = excluded.name, active = TRUE, updated_at = excluded.updated_at SET name = excluded.name, active = TRUE, updated_at = excluded.updated_at
RETURNING id, name, active RETURNING id, name, active
SQL 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 (update-person! config id name active?)
(define clean-name (clean-person-name 'update-person! name)) (let ((clean-name (clean-person-name 'update-person! name)))
(call-with-wiki-database (call-with-wiki-database
config config
(lambda (db) (λ (db)
(define row (let ((row
(query-maybe-row (query-maybe-row
db db
#<<SQL #<<SQL
UPDATE people UPDATE people
SET name = $1, active = $2, updated_at = $3 SET name = $1, active = $2, updated_at = $3
WHERE id = $4 WHERE id = $4
RETURNING id, name, active RETURNING id, name, active
SQL SQL
clean-name (if active? #t #f) (current-seconds) id)) clean-name (if active? #t #f) (current-seconds) id)))
(and row (row->person row))))) (and row (row->person row)))))))
(define (person-tag-names document) (define (person-tag-names document)
(remove-duplicates (remove-duplicates
@@ -91,18 +109,24 @@ SQL
;; Called inside the concept-map write transaction. New names become active; ;; Called inside the concept-map write transaction. New names become active;
;; an explicitly deactivated existing name remains deactivated. ;; 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 (sync-person-tags! db document)
(define now (current-seconds)) (let ((now (current-seconds)))
(for ((name (in-list (person-tag-names document)))) (for ((name (in-list (person-tag-names document))))
(query-exec (query-exec
db db
#<<SQL #<<SQL
INSERT INTO people(name, active, created_at, updated_at) INSERT INTO people(name, active, created_at, updated_at)
VALUES ($1, TRUE, $2, $2) VALUES ($1, TRUE, $2, $2)
ON CONFLICT (lower(name)) DO NOTHING ON CONFLICT (lower(name)) DO NOTHING
SQL SQL
name now)) name now))
(void)) (void)))
(module+ test (module+ test
(require rackunit) (require rackunit)
private/setup.rkt
+92 -92
View File
@@ -24,10 +24,10 @@
(define (bytes->hex value) (define (bytes->hex value)
(apply string-append (apply string-append
(for/list ((byte (in-bytes value))) (for/list ((byte (in-bytes value)))
(define hex (number->string byte 16)) (let ((hex (number->string byte 16)))
(if (= (string-length hex) 1) (if (= (string-length hex) 1)
(string-append "0" hex) (string-append "0" hex)
hex)))) hex)))))
(define setup-form-token (define setup-form-token
(bytes->hex (crypto-random-bytes 32))) (bytes->hex (crypto-random-bytes 32)))
@@ -49,16 +49,16 @@
(vendor-files-ready? config))) (vendor-files-ready? config)))
(define (request-form req) (define (request-form req)
(define body (request-post-data/raw req)) (let ((body (request-post-data/raw req)))
(if body (if body
(form-urlencoded->alist (bytes->string/utf-8 body)) (form-urlencoded->alist (bytes->string/utf-8 body))
'())) '())))
(define (form-value form key [default ""]) (define (form-value form key [default ""])
(define found (assoc key form)) (let ((found (assoc key form)))
(if (and found (cdr found)) (if (and found (cdr found))
(cdr found) (cdr found)
default)) default)))
(define setup-style (define setup-style
#<<CSS #<<CSS
@@ -96,21 +96,21 @@ CSS
(define (language-field config [form '()]) (define (language-field config [form '()])
(define language (form-value form 'language (current-language config))) (let ((language (form-value form 'language (current-language config))))
`((label `((label
,(tr config 'language) ,(tr config 'language)
(select ((name "language")) (select ((name "language"))
(option ((value "en") ,@(if (string-ci=? language "en") '((selected "selected")) '())) ,(tr config 'language-en)) (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)))))) (option ((value "nl") ,@(if (string-ci=? language "nl") '((selected "selected")) '())) ,(tr config 'language-nl)))))))
(define (database-fields config [form '()]) (define (database-fields config [form '()])
(define settings (read-database-settings config)) (let* ((settings (read-database-settings config))
(define ssl-text (ssl-text
(form-value form (form-value form
'db-ssl 'db-ssl
(symbol->string (setting-value settings database-settings-ssl 'no)))) (symbol->string (setting-value settings database-settings-ssl 'no))))
(define ssl (string->symbol ssl-text)) (ssl (string->symbol ssl-text)))
`((h2 ,(tr config 'postgresql)) `((h2 ,(tr config 'postgresql))
(div ((class "fields")) (div ((class "fields"))
(label (label
,(tr config 'server) ,(tr config 'server)
@@ -147,7 +147,7 @@ CSS
(select ((name "db-ssl")) (select ((name "db-ssl"))
(option ((value "no") ,@(if (eq? ssl 'no) '((selected "selected")) '())) ,(tr config 'ssl-no)) (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 "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 '()]) (define (admin-fields config [form '()])
`((h2 ,(tr config 'administrator)) `((h2 ,(tr config 'administrator))
@@ -177,10 +177,10 @@ CSS
(required "required")))))) (required "required"))))))
(define (setup-page config [message #f] [form '()]) (define (setup-page config [message #f] [form '()])
(define db-ready? (database-ready? config)) (let ((db-ready? (database-ready? config))
(define administrator-ready? (admin-ready? config)) (administrator-ready? (admin-ready? config))
(define vendor-ready? (vendor-files-ready? config)) (vendor-ready? (vendor-files-ready? config)))
`(html `(html
(head (head
(meta ((charset "utf-8"))) (meta ((charset "utf-8")))
(meta ((name "viewport") (content "width=device-width, initial-scale=1"))) (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
@@ -210,7 +210,7 @@ CSS
(p ((class "note")) (p ((class "note"))
"Frontend libraries are stored below " "Frontend libraries are stored below "
(code ,(path->string (vendor-directory config))) (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 '()]) (define (setup-page-response config [message #f] [form '()])
(html-response (html-response
@@ -218,85 +218,85 @@ CSS
#:headers (list (make-header #"Cache-Control" #"no-store")))) #:headers (list (make-header #"Cache-Control" #"no-store"))))
(define (validate-admin-form form) (define (validate-admin-form form)
(define username (string-trim (form-value form 'username))) (let ((username (string-trim (form-value form 'username)))
(define display-name (string-trim (form-value form 'display-name))) (display-name (string-trim (form-value form 'display-name)))
(define password (form-value form 'password)) (password (form-value form 'password))
(define password-confirm (form-value form 'password-confirm)) (password-confirm (form-value form 'password-confirm)))
(cond (cond
((string=? username "") "Administrator username is required.") ((string=? username "") "Administrator username is required.")
((string=? password "") "Administrator password is required.") ((string=? password "") "Administrator password is required.")
((< (string-length password) 8) "Administrator password must contain at least 8 characters.") ((< (string-length password) 8) "Administrator password must contain at least 8 characters.")
((not (string=? password password-confirm)) "The two passwords do not match.") ((not (string=? password password-confirm)) "The two passwords do not match.")
(else (else
(list username (list username
(if (string=? display-name "") username display-name) (if (string=? display-name "") username display-name)
password)))) password)))))
(define (form->database-settings form) (define (form->database-settings form)
(define port (string->number (form-value form 'db-port "5432"))) (let* ((port (string->number (form-value form 'db-port "5432")))
(define ssl-text (form-value form 'db-ssl "no")) (ssl-text (form-value form 'db-ssl "no"))
(define ssl (ssl
(cond
((string=? ssl-text "yes") 'yes)
((string=? ssl-text "optional") 'optional)
(else 'no))))
(cond (cond
((string=? ssl-text "yes") 'yes) ((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.")
((string=? ssl-text "optional") 'optional) ((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.")
(else 'no))) ((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.")
(cond ((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.")
((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.") (else
((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.") (database-settings (string-trim (form-value form 'db-server))
((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.") port
((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.") (string-trim (form-value form 'db-database))
(else (string-trim (form-value form 'db-user))
(database-settings (string-trim (form-value form 'db-server)) (form-value form 'db-password)
port ssl)))))
(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 (configure-language! config form)
(define language (string-downcase (form-value form 'language (current-language config)))) (let ((language (string-downcase (form-value form 'language (current-language config)))))
(unless (member language '("en" "nl")) (unless (member language '("en" "nl"))
(error 'setup "Unsupported UI language: ~a" language)) (error 'setup "Unsupported UI language: ~a" language))
(write-language! config language)) (write-language! config language)))
(define (configure-database! config form) (define (configure-database! config form)
(unless (database-ready? config) (unless (database-ready? config)
(define settings (form->database-settings form)) (let ((settings (form->database-settings form)))
(when (string? settings) (when (string? settings)
(error 'setup settings)) (error 'setup settings))
(test-database-settings! settings) (test-database-settings! settings)
(initialize-database-with-settings! settings config) (initialize-database-with-settings! settings config)
(write-database-settings! config settings))) (write-database-settings! config settings))))
(define (configure-administrator! config form) (define (configure-administrator! config form)
(unless (admin-ready? config) (unless (admin-ready? config)
(define admin-values (validate-admin-form form)) (let ((admin-values (validate-admin-form form)))
(when (string? admin-values) (when (string? admin-values)
(error 'setup admin-values)) (error 'setup admin-values))
(create-user! config (create-user! config
(list-ref admin-values 0) (list-ref admin-values 0)
(list-ref admin-values 1) (list-ref admin-values 1)
(list-ref admin-values 2) (list-ref admin-values 2)
'admin 'admin
'enabled))) 'enabled))))
(define (cleartext-password-error? message) (define (cleartext-password-error? message)
(and (string? message) (and (string? message)
(regexp-match? #rx"refusing to send cleartext password" message))) (regexp-match? #rx"refusing to send cleartext password" message)))
(define (setup-error-message e) (define (setup-error-message e)
(define message (exn-message e)) (let ((message (exn-message e)))
(if (cleartext-password-error? message) (if (cleartext-password-error? message)
(string-append (string-append
"PostgreSQL requests cleartext password authentication. " "PostgreSQL requests cleartext password authentication. "
"Configure the matching pg_hba.conf rule for this database/user to use " "Configure the matching pg_hba.conf rule for this database/user to use "
"scram-sha-256 (recommended), then reload PostgreSQL and try again. " "scram-sha-256 (recommended), then reload PostgreSQL and try again. "
"If more than one pg_hba.conf rule could match, remember that PostgreSQL " "If more than one pg_hba.conf rule could match, remember that PostgreSQL "
"uses the first matching rule. " "uses the first matching rule. "
"The entered non-password fields have been preserved below.\n\n" "The entered non-password fields have been preserved below.\n\n"
"Technical detail: " message) "Technical detail: " message)
message)) message)))
(define (complete-setup! config req) (define (complete-setup! config req)
(call-with-semaphore (call-with-semaphore
private/storage.rkt
+263 -252
View File
@@ -50,15 +50,15 @@
; post : The data directory and writable static directory exist. ; post : The data directory and writable static directory exist.
; result : void. ; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ensure-wiki-data! config) (define (ensure-wiki-data! config)
(for ((directory (in-list (list (wiki-config-data-dir config) (for ((directory (in-list (list (wiki-config-data-dir config)
(data-static-directory config))))) (data-static-directory config)))))
(make-directory* directory))) (make-directory* directory)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (slug-alphanumeric? char) (define (slug-alphanumeric? char)
(or (char-alphabetic? char) (or (char-alphabetic? char)
(char-numeric? char))) (char-numeric? char)))
@@ -74,6 +74,12 @@
(char=? char #\_) (char=? char #\_)
(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) (define (valid-slug? slug)
(and (> (string-length slug) 0) (and (> (string-length slug) 0)
(<= (string-length slug) 120) (<= (string-length slug) 120)
@@ -100,10 +106,10 @@
; result : Two values: namespace and slug. The namespace is empty for root pages. ; result : Two values: namespace and slug. The namespace is empty for root pages.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (split-page-reference reference) (define (split-page-reference reference)
(define match (regexp-match #px"^([^:]+):(.*)$" reference)) (let ((match (regexp-match #px"^([^:]+):(.*)$" reference)))
(if match (if match
(values (list-ref match 1) (list-ref match 2)) (values (list-ref match 1) (list-ref match 2))
(values "" reference))) (values "" reference))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether a namespace-qualified page reference is valid. ; 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. ; result : #t for root slugs or namespace:slug references with letter/number namespaces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (valid-page-reference? reference) (define (valid-page-reference? reference)
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(and (valid-slug? slug) (and (valid-slug? slug)
(or (string=? namespace "") (or (string=? namespace "")
(and (valid-slug? namespace) (and (valid-slug? namespace)
(<= (string-length namespace) 80))))) (<= (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 (title->slug title)
(define normalized (let ((normalized
(string-downcase (string-downcase
(string-normalize-nfkd (string-trim title)))) (string-normalize-nfkd (string-trim title))))
(define out (open-output-string)) (out (open-output-string))
(define separator-needed? #f) (separator-needed? #f)
(define wrote-character? #f) (wrote-character? #f))
(for ((char (in-string normalized))) (for ((char (in-string normalized)))
(cond (cond
((slug-alphanumeric? char) ((slug-alphanumeric? char)
(when (and separator-needed? wrote-character?) (when (and separator-needed? wrote-character?)
(write-char #\- out)) (write-char #\- out))
(write-char char out) (write-char char out)
(set! separator-needed? #f) (set! separator-needed? #f)
(set! wrote-character? #t)) (set! wrote-character? #t))
((combining-mark? char) ((combining-mark? char)
(void)) (void))
(else (else
(set! separator-needed? #t)))) (set! separator-needed? #t))))
(define slug (get-output-string out)) (let* ((slug (get-output-string out))
(define limited (limited
(if (> (string-length slug) 120) (if (> (string-length slug) 120)
(substring slug 0 120) (substring slug 0 120)
slug)) slug)))
(regexp-replace #px"-+$" limited "")) (regexp-replace #px"-+$" limited ""))))
(define (tags->text tags) (define (tags->text tags)
(jsexpr->string tags)) (jsexpr->string tags))
(define (text->tags text) (define (text->tags text)
(with-handlers ((exn:fail? (λ (_e) '()))) (with-handlers ((exn:fail? (λ (_e) '())))
(define value (string->jsexpr text)) (let ((value (string->jsexpr text)))
(if (list? value) value '()))) (if (list? value) value '()))))
(define (row->page row [include-markdown? #t]) (define (row->page row [include-markdown? #t])
(define namespace (vector-ref row 9)) (let* ((namespace (vector-ref row 9))
(define slug (vector-ref row 0)) (slug (vector-ref row 0))
(define result (result
(hash 'slug (page-reference namespace slug) (hash 'slug (page-reference namespace slug)
'pageSlug slug 'pageSlug slug
'namespace namespace 'namespace namespace
'title (vector-ref row 1) 'title (vector-ref row 1)
'createdAt (vector-ref row 3) 'createdAt (vector-ref row 3)
'updatedAt (vector-ref row 4) 'updatedAt (vector-ref row 4)
'createdBy (vector-ref row 5) 'createdBy (vector-ref row 5)
'updatedBy (vector-ref row 6) 'updatedBy (vector-ref row 6)
'tags (text->tags (vector-ref row 7)) 'tags (text->tags (vector-ref row 7))
'currentVersion (vector-ref row 8))) 'currentVersion (vector-ref row 8))))
(if include-markdown? (if include-markdown?
(hash-set result 'markdown (vector-ref row 2)) (hash-set result 'markdown (vector-ref row 2))
result)) result)))
(define page-columns (define page-columns
"slug, title, markdown, created_at, updated_at, created_by, updated_by, tags, current_version, namespace") "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") "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 (page-id/db db namespace slug)
(define current-id (let ((current-id
(query-maybe-value db (query-maybe-value db
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE" "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
namespace slug)) namespace slug)))
(if current-id (if current-id
current-id current-id
(query-maybe-value db (query-maybe-value db
#<<SQL #<<SQL
SELECT p.id SELECT p.id
FROM page_aliases a FROM page_aliases a
JOIN pages p ON p.id = a.page_id JOIN pages p ON p.id = a.page_id
WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE
SQL SQL
namespace slug))) namespace slug))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List current wiki page metadata. ; goal : List current wiki page metadata.
@@ -221,21 +233,21 @@ SQL
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define row (let* ((row
(query-maybe-row db (query-maybe-row db
(string-append "SELECT " page-columns (string-append "SELECT " page-columns
" FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE") " FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE")
namespace slug)) namespace slug))
(define resolved-row (resolved-row
(if row (if row
row row
(query-maybe-row db (query-maybe-row db
(string-append (string-append
"SELECT " page-columns/prefixed "SELECT " page-columns/prefixed
" FROM page_aliases a JOIN pages p ON p.id = a.page_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") " WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE")
namespace slug))) namespace slug))))
(if resolved-row (row->page resolved-row) #f)))))) (if resolved-row (row->page resolved-row) #f)))))))
(define (replace-todos! db page-id markdown) (define (replace-todos! db page-id markdown)
(query-exec db "DELETE FROM todo_items WHERE page_id = $1" page-id) (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. ; result : The new page metadata with Markdown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-page! config reference title markdown author [summary "Created page"] [tags '()]) (define (create-page! config reference title markdown author [summary "Created page"] [tags '()])
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(call-with-transaction (call-with-transaction
db db
(λ () (λ ()
(define now (current-seconds)) (let* ((now (current-seconds))
(define page-id (page-id
(query-value db (query-value db
#<<SQL #<<SQL
INSERT INTO pages(namespace, slug, title, markdown, tags, current_version, INSERT INTO pages(namespace, slug, title, markdown, tags, current_version,
created_at, updated_at, created_by, updated_by, search_document) created_at, updated_at, created_by, updated_by, search_document)
VALUES ($1, $2, $3, $4, $5, 1, $6, $6, $7, $7, 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')) setweight(to_tsvector('simple', coalesce($4, '')), 'B'))
RETURNING id RETURNING id
SQL SQL
namespace slug title markdown (tags->text tags) now author)) namespace slug title markdown (tags->text tags) now author))
(define page-version-id (page-version-id
(insert-version! db page-id 1 title markdown author "create" summary now tags)) (insert-version! db page-id 1 title markdown author "create" summary now tags)))
(replace-todos! db page-id markdown) (replace-todos! db page-id markdown)
(replace-current-attachment-references! db page-id markdown now) (replace-current-attachment-references! db page-id markdown now)
(record-version-attachment-references! db page-id page-version-id markdown now))))) (record-version-attachment-references! db page-id page-version-id markdown now))))))
(read-page config reference)) (read-page config reference)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Save a new version of an existing wiki page. ; goal : Save a new version of an existing wiki page.
@@ -296,36 +308,35 @@ SQL
; result : The updated page metadata with Markdown. ; 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 (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)) (let-values (((namespace slug) (split-page-reference reference)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(call-with-transaction (call-with-transaction
db db
(λ () (λ ()
(define row (let ((row
(query-maybe-row db (query-maybe-row db
"SELECT id, current_version, tags, namespace FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE" "SELECT id, current_version, tags, namespace FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
namespace slug)) namespace slug)))
(unless row (unless row
(error 'update-page! "unknown page: ~a" slug)) (error 'update-page! "unknown page: ~a" slug))
(define current-version (vector-ref row 1)) (let* ((current-version (vector-ref row 1))
(define supplied-version (supplied-version
(if (number? base-version) (if (number? base-version)
base-version base-version
(string->number (format "~a" base-version)))) (string->number (format "~a" base-version))))
(unless (and supplied-version (= current-version supplied-version)) (page-tags (if tags tags (text->tags (vector-ref row 2))))
(error 'update-page! "version-conflict")) (target-namespace (vector-ref row 3))
(define page-tags (next-version (+ current-version 1))
(if tags tags (text->tags (vector-ref row 2)))) (now (current-seconds)))
(define target-namespace (vector-ref row 3)) (unless (and supplied-version (= current-version supplied-version))
(when (and (not (eq? new-namespace #f)) (error 'update-page! "version-conflict"))
(not (string=? (string-trim new-namespace) target-namespace))) (when (and (not (eq? new-namespace #f))
(error 'update-page! "use rename-page! to change a page namespace")) (not (string=? (string-trim new-namespace) target-namespace)))
(define next-version (+ current-version 1)) (error 'update-page! "use rename-page! to change a page namespace"))
(define now (current-seconds)) (query-exec db
(query-exec db #<<SQL
#<<SQL
UPDATE pages UPDATE pages
SET title = $1, markdown = $2, tags = $3, current_version = $4, SET title = $1, markdown = $2, tags = $3, current_version = $4,
updated_at = $5, updated_by = $6, namespace = $7, 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') setweight(to_tsvector('simple', coalesce($2, '')), 'B')
WHERE id = $8 WHERE id = $8
SQL SQL
title markdown (tags->text page-tags) next-version now author target-namespace (vector-ref row 0)) title markdown (tags->text page-tags) next-version now author target-namespace (vector-ref row 0))
(define page-id (vector-ref row 0)) (let* ((page-id (vector-ref row 0))
(define page-version-id (page-version-id
(insert-version! db page-id next-version title markdown author "edit" summary now page-tags)) (insert-version! db page-id next-version title markdown author "edit" summary now page-tags)))
(replace-todos! db page-id markdown) (replace-todos! db page-id markdown)
(replace-current-attachment-references! db page-id markdown now) (replace-current-attachment-references! db page-id markdown now)
(record-version-attachment-references! db page-id page-version-id markdown now))))) (record-version-attachment-references! db page-id page-version-id markdown now))))))))
(read-page config (page-reference namespace slug))) (read-page config (page-reference namespace slug))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Rename or move a page while keeping its old address as an alias. ; 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. ; result : The renamed page metadata with Markdown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (rename-page! config reference title target-namespace target-slug author [summary "Renamed page"]) (define (rename-page! config reference title target-namespace target-slug author [summary "Renamed page"])
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(define clean-namespace (string-trim target-namespace)) (let ((clean-namespace (string-trim target-namespace))
(define clean-slug (string-trim target-slug)) (clean-slug (string-trim target-slug)))
(unless (valid-page-reference? (page-reference clean-namespace clean-slug)) (unless (valid-page-reference? (page-reference clean-namespace clean-slug))
(error 'rename-page! "invalid page address: ~a" (page-reference clean-namespace clean-slug))) (error 'rename-page! "invalid page address: ~a" (page-reference clean-namespace clean-slug)))
(when (string=? (string-trim title) "") (when (string=? (string-trim title) "")
(error 'rename-page! "title is required")) (error 'rename-page! "title is required"))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(call-with-transaction (call-with-transaction
db db
(λ () (λ ()
(define row (let ((row
(query-maybe-row db (query-maybe-row db
"SELECT id, title, markdown, tags, current_version FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE" "SELECT id, title, markdown, tags, current_version FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
namespace slug)) namespace slug)))
(unless row (unless row
(error 'rename-page! "unknown page: ~a" reference)) (error 'rename-page! "unknown page: ~a" reference))
(define page-id (vector-ref row 0)) (let* ((page-id (vector-ref row 0))
(define old-title (vector-ref row 1)) (old-title (vector-ref row 1))
(define markdown (vector-ref row 2)) (markdown (vector-ref row 2))
(define tags (text->tags (vector-ref row 3))) (tags (text->tags (vector-ref row 3)))
(define current-version (vector-ref row 4)) (current-version (vector-ref row 4))
(define address-changed? (address-changed?
(or (not (string=? namespace clean-namespace)) (or (not (string=? namespace clean-namespace))
(not (string=? slug clean-slug)))) (not (string=? slug clean-slug)))))
(when address-changed? (when address-changed?
(define target-page-id (let ((target-page-id
(query-maybe-value db (query-maybe-value db
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE" "SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
clean-namespace clean-slug)) clean-namespace clean-slug))
(when (and target-page-id (not (= target-page-id page-id))) (target-alias-page-id
(error 'rename-page! "page address is already in use: ~a" (query-maybe-value db
(page-reference clean-namespace clean-slug))) "SELECT page_id FROM page_aliases WHERE namespace = $1 AND slug = $2"
(define target-alias-page-id clean-namespace clean-slug)))
(query-maybe-value db (when (and target-page-id (not (= target-page-id page-id)))
"SELECT page_id FROM page_aliases WHERE namespace = $1 AND slug = $2" (error 'rename-page! "page address is already in use: ~a"
clean-namespace clean-slug)) (page-reference clean-namespace clean-slug)))
(when (and target-alias-page-id (not (= target-alias-page-id page-id))) (when (and target-alias-page-id (not (= target-alias-page-id page-id)))
(error 'rename-page! "page address is already an alias: ~a" (error 'rename-page! "page address is already an alias: ~a"
(page-reference clean-namespace clean-slug))) (page-reference clean-namespace clean-slug)))
(when target-alias-page-id (when target-alias-page-id
(query-exec db (query-exec db
"DELETE FROM page_aliases WHERE namespace = $1 AND slug = $2 AND page_id = $3" "DELETE FROM page_aliases WHERE namespace = $1 AND slug = $2 AND page_id = $3"
clean-namespace clean-slug page-id)) clean-namespace clean-slug page-id))
(query-exec db (query-exec db
#<<SQL #<<SQL
INSERT INTO page_aliases(namespace, slug, title, page_id, created_at, created_by) INSERT INTO page_aliases(namespace, slug, title, page_id, created_at, created_by)
VALUES ($1, $2, $3, $4, $5, $6) VALUES ($1, $2, $3, $4, $5, $6)
ON CONFLICT (namespace, slug) DO NOTHING ON CONFLICT (namespace, slug) DO NOTHING
SQL SQL
namespace slug old-title page-id (current-seconds) author)) namespace slug old-title page-id (current-seconds) author)))
(define next-version (+ current-version 1)) (let ((next-version (+ current-version 1))
(define now (current-seconds)) (now (current-seconds)))
(query-exec db (query-exec db
#<<SQL #<<SQL
UPDATE pages UPDATE pages
SET namespace = $1, slug = $2, title = $3, current_version = $4, SET namespace = $1, slug = $2, title = $3, current_version = $4,
updated_at = $5, updated_by = $6, 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') setweight(to_tsvector('simple', coalesce(markdown, '')), 'B')
WHERE id = $7 WHERE id = $7
SQL SQL
clean-namespace clean-slug title next-version now author page-id) clean-namespace clean-slug title next-version now author page-id)
(define page-version-id (let ((page-version-id
(insert-version! db page-id next-version title markdown author "rename" summary now tags)) (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))))) (record-version-attachment-references! db page-id page-version-id markdown now)))))))))
(read-page config (page-reference clean-namespace clean-slug))) (read-page config (page-reference clean-namespace clean-slug)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Archive an existing wiki page. ; goal : Archive an existing wiki page.
@@ -427,32 +438,32 @@ SQL
; result : void. ; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (archive-page! config reference author) (define (archive-page! config reference author)
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define id (let ((id
(query-maybe-value db (query-maybe-value db
#<<SQL #<<SQL
UPDATE pages UPDATE pages
SET archived = TRUE, archived_at = $1, archived_by = $2 SET archived = TRUE, archived_at = $1, archived_by = $2
WHERE namespace = $3 AND slug = $4 AND archived = FALSE WHERE namespace = $3 AND slug = $4 AND archived = FALSE
RETURNING id RETURNING id
SQL SQL
(current-seconds) author namespace slug)) (current-seconds) author namespace slug)))
(unless id (unless id
(error 'archive-page! "unknown page: ~a" slug)) (error 'archive-page! "unknown page: ~a" slug))
(query-exec db (query-exec db
"DELETE FROM attachment_references WHERE page_id = $1 AND current_reference = TRUE" "DELETE FROM attachment_references WHERE page_id = $1 AND current_reference = TRUE"
id))) id))))
(void)) (void)))
(define (page-id config reference) (define (page-id config reference)
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(page-id/db db namespace slug)))) (page-id/db db namespace slug)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the version history for a wiki page. ; goal : Read the version history for a wiki page.
@@ -461,29 +472,29 @@ SQL
; result : A newest-first list of version metadata hashes. ; result : A newest-first list of version metadata hashes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (page-history config reference) (define (page-history config reference)
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define id (page-id/db db namespace slug)) (let ((id (page-id/db db namespace slug)))
(unless id (unless id
(error 'page-history "unknown page: ~a" slug)) (error 'page-history "unknown page: ~a" slug))
(for/list ((row (in-list (for/list ((row (in-list
(query-rows db (query-rows db
#<<SQL #<<SQL
SELECT version, title, author, action, summary, tags, created_at SELECT version, title, author, action, summary, tags, created_at
FROM page_versions FROM page_versions
WHERE page_id = $1 WHERE page_id = $1
ORDER BY version DESC ORDER BY version DESC
SQL SQL
id)))) id))))
(hash 'version (vector-ref row 0) (hash 'version (vector-ref row 0)
'title (vector-ref row 1) 'title (vector-ref row 1)
'author (vector-ref row 2) 'author (vector-ref row 2)
'action (vector-ref row 3) 'action (vector-ref row 3)
'summary (vector-ref row 4) 'summary (vector-ref row 4)
'tags (text->tags (vector-ref row 5)) 'tags (text->tags (vector-ref row 5))
'createdAt (vector-ref row 6)))))) 'createdAt (vector-ref row 6))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read one stored page version. ; goal : Read one stored page version.
@@ -492,32 +503,32 @@ SQL
; result : Version metadata with Markdown, or #f when the version is absent. ; result : Version metadata with Markdown, or #f when the version is absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-version config reference version) (define (read-version config reference version)
(define-values (namespace slug) (split-page-reference reference)) (let-values (((namespace slug) (split-page-reference reference)))
(define version-number (let ((version-number
(if (number? version) version (string->number version))) (if (number? version) version (string->number version))))
(and version-number (and version-number
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define id (page-id/db db namespace slug)) (let* ((id (page-id/db db namespace slug))
(define row (row
(and id (and id
(query-maybe-row db (query-maybe-row db
#<<SQL #<<SQL
SELECT version, title, markdown, author, action, summary, tags, created_at SELECT version, title, markdown, author, action, summary, tags, created_at
FROM page_versions FROM page_versions
WHERE page_id = $1 AND version = $2 WHERE page_id = $1 AND version = $2
SQL SQL
id version-number))) id version-number))))
(and row (and row
(hash 'version (vector-ref row 0) (hash 'version (vector-ref row 0)
'title (vector-ref row 1) 'title (vector-ref row 1)
'markdown (vector-ref row 2) 'markdown (vector-ref row 2)
'author (vector-ref row 3) 'author (vector-ref row 3)
'action (vector-ref row 4) 'action (vector-ref row 4)
'summary (vector-ref row 5) 'summary (vector-ref row 5)
'tags (text->tags (vector-ref row 6)) 'tags (text->tags (vector-ref row 6))
'createdAt (vector-ref row 7))))))) 'createdAt (vector-ref row 7))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Search current wiki pages using PostgreSQL full-text search. ; 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. ; result : A list of hashes containing item number, line number and text.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (extract-todos markdown) (define (extract-todos markdown)
(define lines (string-split markdown "\n" #:trim? #f)) (let ((lines (string-split markdown "\n" #:trim? #f))
(define in-fence? #f) (in-fence? #f)
(define item-number 0) (item-number 0)
(define result '()) (result '()))
(for ((line (in-list lines)) (for ((line (in-list lines))
(line-number (in-naturals 1))) (line-number (in-naturals 1)))
(define trimmed (string-trim line)) (let ((trimmed (string-trim line)))
(cond (cond
((regexp-match? #px"^(```|~~~)" trimmed) ((regexp-match? #px"^(```|~~~)" trimmed)
(set! in-fence? (not in-fence?))) (set! in-fence? (not in-fence?)))
((not in-fence?) ((not in-fence?)
(for ((match (in-list (regexp-match* #px"[Tt][Oo][Dd][Oo]\\([^()]+\\)" line)))) (for ((match (in-list (regexp-match* #px"[Tt][Oo][Dd][Oo]\\([^()]+\\)" line))))
(define text (string-trim (substring match 5 (- (string-length match) 1)))) (let ((text (string-trim (substring match 5 (- (string-length match) 1)))))
(when (not (string=? text "")) (when (not (string=? text ""))
(set! item-number (+ item-number 1)) (set! item-number (+ item-number 1))
(set! result (set! result
(cons (hash 'number item-number (cons (hash 'number item-number
'line line-number 'line line-number
'text text) 'text text)
result))))))) result)))))))))
(reverse 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"))) "https://cdn.jsdelivr.net/npm/diff2html@3.4.56/bundles/css/diff2html.min.css")))
(define (vendor-file-ready? config name) (define (vendor-file-ready? config name)
(define path (build-path (vendor-directory config) name)) (let ((path (build-path (vendor-directory config) name)))
(and (file-exists? path) (and (file-exists? path)
(> (file-size path) 0))) (> (file-size path) 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether all required browser libraries are installed. ; goal : Check whether all required browser libraries are installed.
@@ -56,40 +56,40 @@
(define (download-content source) (define (download-content source)
(parameterize ((current-https-protocol 'secure)) (parameterize ((current-https-protocol 'secure))
(define-values (in headers) (let-values (((in headers)
(get-pure-port/headers (string->url source) (get-pure-port/headers (string->url source)
'() '()
#:redirections 5 #:redirections 5
#:status? #t)) #:status? #t)))
(dynamic-wind (dynamic-wind
void void
(λ () (λ ()
(define status-match (let ((status-match
(regexp-match #px"^HTTP/[^ ]+ ([0-9][0-9][0-9])" headers)) (regexp-match #px"^HTTP/[^ ]+ ([0-9][0-9][0-9])" headers)))
(unless (and status-match (unless (and status-match
(= (string->number (list-ref status-match 1)) 200)) (= (string->number (list-ref status-match 1)) 200))
(error 'download-vendor-files! (error 'download-vendor-files!
"download failed for ~a: ~a" "download failed for ~a: ~a"
source source
(or (and status-match (list-ref status-match 1)) (or (and status-match (list-ref status-match 1))
"invalid HTTP status"))) "invalid HTTP status")))
(port->bytes in)) (port->bytes in)))
(λ () (λ ()
(close-input-port in))))) (close-input-port in))))))
(define (download-file! config name source) (define (download-file! config name source)
(define directory (vendor-directory config)) (let* ((directory (vendor-directory config))
(define target (build-path directory name)) (target (build-path directory name))
(define temporary-target (temporary-target
(build-path directory (string-append name ".download"))) (build-path directory (string-append name ".download")))
(define content (download-content source)) (content (download-content source)))
(make-directory* (path-only target)) (make-directory* (path-only target))
(call-with-output-file temporary-target (call-with-output-file temporary-target
(λ (out) (λ (out)
(write-bytes content out)) (write-bytes content out))
#:exists 'truncate/replace) #:exists 'truncate/replace)
(rename-file-or-directory temporary-target target #t) (rename-file-or-directory temporary-target target #t)
(void)) (void)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Download all browser libraries required by the wiki frontend. ; goal : Download all browser libraries required by the wiki frontend.
@@ -101,10 +101,10 @@
(define (download-vendor-files! config) (define (download-vendor-files! config)
(make-directory* (vendor-directory config)) (make-directory* (vendor-directory config))
(for ([entry (in-list vendor-files)]) (for ([entry (in-list vendor-files)])
(define name (car entry)) (let ((name (car entry))
(define source (cdr entry)) (source (cdr entry)))
(unless (vendor-file-ready? config name) (unless (vendor-file-ready? config name)
(download-file! config name source))) (download-file! config name source))))
(unless (vendor-files-ready? config) (unless (vendor-files-ready? config)
(error 'download-vendor-files! "frontend vendor setup is incomplete")) (error 'download-vendor-files! "frontend vendor setup is incomplete"))
(void)) (void))
scrbl/racket-wiki.scrbl
+24
View File
@@ -150,6 +150,30 @@ for page-local checklists.
@defmodule[racket-wiki/translate] @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?] { @defproc[(tr [config any/c] [key symbol?]) string?] {
Returns the effective UI translation for @racket[key]. Built-in English and Returns the effective UI translation for @racket[key]. Built-in English and
Dutch translations are available before the database is configured. Once the 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) (define (people-list-handler config req)
(require-role (require-role
config req 'reader config req 'reader
(lambda (_session) (λ (_session)
(json-response (hash 'people (list-people config #t)))))) (json-response (hash 'people (list-people config #t))))))
(define (people-create-handler config req) (define (people-create-handler config req)
(require-write-role (require-write-role
config req 'editor config req 'editor
(lambda (_session) (λ (_session)
(with-handlers ((exn:fail? (lambda (e) (json-error 400 (exn-message e))))) (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
(define body (request-json req)) (define body (request-json req))
(json-response (create-person! config (hash-ref body 'name "")) #:code 201))))) (json-response (create-person! config (hash-ref body 'name "")) #:code 201)))))
(define (people-update-handler config req id) (define (people-update-handler config req id)
(require-write-role (require-write-role
config req 'editor config req 'editor
(lambda (_session) (λ (_session)
(with-handlers ((exn:fail? (lambda (e) (json-error 400 (exn-message e))))) (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
(define body (request-json req)) (define body (request-json req))
(define active (hash-ref body 'active #t)) (define active (hash-ref body 'active #t))
(unless (boolean? active) (unless (boolean? active)
@@ -441,7 +441,7 @@ CSS
(define (concept-map-version-delete-handler config req slug version) (define (concept-map-version-delete-handler config req slug version)
(require-write-role (require-write-role
config req 'editor config req 'editor
(lambda (_session) (λ (_session)
(if (delete-concept-map-version! config slug version) (if (delete-concept-map-version! config slug version)
(json-response (hash 'ok #t)) (json-response (hash 'ok #t))
(json-error 404 "Concept map history item not found"))))) (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") (if (string-ci=? (bytes->string/latin-1 (request-method req)) "GET")
(require-role (require-role
config req 'reader config req 'reader
(lambda (_session) (λ (_session)
(json-response (hash 'styles (or (read-cmap-styles config) 'null))))) (json-response (hash 'styles (or (read-cmap-styles config) 'null)))))
(require-write-role (require-write-role
config req 'editor config req 'editor
(lambda (_session) (λ (_session)
(with-handlers ([exn:fail? (lambda (e) (json-error 400 (exn-message e)))]) (with-handlers ([exn:fail? (λ (e) (json-error 400 (exn-message e)))])
(define body (request-json req)) (define body (request-json req))
(json-response (json-response
(hash 'styles (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) (define (base-translations language)
(if (string-ci=? language "nl") dutch english)) (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) (define (current-language config)
(with-handlers ((exn:fail? (λ (_e) (wiki-config-language config)))) (with-handlers ((exn:fail? (λ (_e) (wiki-config-language config))))
(if (file-exists? (language-config-path config)) (if (file-exists? (language-config-path config))
(call-with-input-file (language-config-path config) (call-with-input-file (language-config-path config)
(λ (in) (λ (in)
(define value (read in)) (let ((value (read in)))
(if (string? value) value (wiki-config-language config)))) (if (string? value) value (wiki-config-language config)))))
(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) (define (write-language! config language)
(make-directory* (wiki-config-data-dir config)) (make-directory* (wiki-config-data-dir config))
(call-with-output-file (language-config-path config) (call-with-output-file (language-config-path config)
@@ -325,26 +337,26 @@
; result : Text containing every known key with nl and en values. ; result : Text containing every known key with nl and en values.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translation-page-template) (define (translation-page-template)
(define keys (let ((keys
(sort (remove-duplicates (append (hash-keys english) (hash-keys dutch))) (sort (remove-duplicates (append (hash-keys english) (hash-keys dutch)))
string<? string<?
#:key symbol->string)) #:key symbol->string)))
(string-join (string-join
(for/list ((key (in-list keys))) (for/list ((key (in-list keys)))
(format "~a = nl:~a, en:~a" (format "~a = nl:~a, en:~a"
(symbol->string key) (symbol->string key)
(translation-value->text (hash-ref dutch key (hash-ref english key ""))) (translation-value->text (hash-ref dutch key (hash-ref english key "")))
(translation-value->text (hash-ref english key "")))) (translation-value->text (hash-ref english key ""))))
"\n")) "\n")))
(define (unquote-translation-value value) (define (unquote-translation-value value)
(define text (string-trim value)) (let ((text (string-trim value)))
(if (and (>= (string-length text) 2) (if (and (>= (string-length text) 2)
(char=? (string-ref text 0) #\") (char=? (string-ref text 0) #\")
(char=? (string-ref text (sub1 (string-length text))) #\")) (char=? (string-ref text (sub1 (string-length text))) #\"))
(let ((body (substring text 1 (sub1 (string-length text))))) (let ((body (substring text 1 (sub1 (string-length text)))))
(string-replace (string-replace body "\\\"" "\"") "\\\\" "\\")) (string-replace (string-replace body "\\\"" "\"") "\\\\" "\\"))
text)) text)))
(define (split-translation-variants text) (define (split-translation-variants text)
(let loop ((i 0) (let loop ((i 0)
@@ -370,24 +382,24 @@
(define (parse-translation-variants text) (define (parse-translation-variants text)
(for/fold ((result (hash))) (for/fold ((result (hash)))
((part (in-list (split-translation-variants text)))) ((part (in-list (split-translation-variants text))))
(define match (regexp-match #px"^\\s*([A-Za-z][A-Za-z0-9_-]*)\\s*:(.*)$" part)) (let ((match (regexp-match #px"^\\s*([A-Za-z][A-Za-z0-9_-]*)\\s*:(.*)$" part)))
(if match (if match
(hash-set result (hash-set result
(string-downcase (list-ref match 1)) (string-downcase (list-ref match 1))
(unquote-translation-value (list-ref match 2))) (unquote-translation-value (list-ref match 2)))
result))) result))))
(define (parse-overrides markdown) (define (parse-overrides markdown)
(for/fold ((result (hash))) (for/fold ((result (hash)))
((line (in-list (string-split markdown "\n")))) ((line (in-list (string-split markdown "\n"))))
(define match (let ((match
(regexp-match #px"^\\s*([A-Za-z0-9._-]+)\\s*=\\s*(.*?)\\s*$" line)) (regexp-match #px"^\\s*([A-Za-z0-9._-]+)\\s*=\\s*(.*?)\\s*$" line)))
(if match (if match
(let ((variants (parse-translation-variants (list-ref match 2)))) (let ((variants (parse-translation-variants (list-ref match 2))))
(if (zero? (hash-count variants)) (if (zero? (hash-count variants))
result result
(hash-set result (string->symbol (list-ref match 1)) variants))) (hash-set result (string->symbol (list-ref match 1)) variants)))
result))) result))))
(define (database-overrides config) (define (database-overrides config)
(with-handlers ((exn:fail? (λ (_e) (hash)))) (with-handlers ((exn:fail? (λ (_e) (hash))))
@@ -396,20 +408,20 @@
(call-with-wiki-database (call-with-wiki-database
config config
(λ (db) (λ (db)
(define markdown (let ((markdown
(query-maybe-value db (query-maybe-value db
"SELECT markdown FROM pages WHERE namespace = '' AND slug = $1 AND archived = FALSE" "SELECT markdown FROM pages WHERE namespace = '' AND slug = $1 AND archived = FALSE"
(translation-page-slug))) (translation-page-slug))))
(if markdown (parse-overrides markdown) (hash))))))) (if markdown (parse-overrides markdown) (hash))))))))
(define (translation-override-for-language variants language) (define (translation-override-for-language variants language)
(define language-key (string-downcase language)) (let ((language-key (string-downcase language)))
(cond (cond
((hash-has-key? variants language-key) ((hash-has-key? variants language-key)
(hash-ref variants language-key)) (hash-ref variants language-key))
((hash-has-key? variants "en") ((hash-has-key? variants "en")
(hash-ref variants "en")) (hash-ref variants "en"))
(else #f))) (else #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Return all translations active for the configured wiki language. ; goal : Return all translations active for the configured wiki language.
@@ -418,13 +430,13 @@
; result : A hash from translation symbols to strings. ; result : A hash from translation symbols to strings.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translations-for config) (define (translations-for config)
(define language (current-language config)) (let ((language (current-language config)))
(for/fold ((result (base-translations language))) (for/fold ((result (base-translations language)))
(((key variants) (in-hash (database-overrides config)))) (((key variants) (in-hash (database-overrides config))))
(define value (translation-override-for-language variants language)) (let ((value (translation-override-for-language variants language)))
(if value (if value
(hash-set result key value) (hash-set result key value)
result))) result)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Translate one UI key for the configured wiki language. ; goal : Translate one UI key for the configured wiki language.