849 lines
32 KiB
Racket
849 lines
32 KiB
Racket
#lang racket/base
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; HTTP routing and server-rendered setup/login handling.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require net/url
|
|
net/uri-codec
|
|
racket/file
|
|
racket/list
|
|
racket/string
|
|
(prefix-in cookie: net/cookies/server)
|
|
web-server/dispatch
|
|
web-server/dispatchers/dispatch
|
|
web-server/http
|
|
web-server/servlet-env
|
|
"private/auth.rkt"
|
|
"private/cmap-storage.rkt"
|
|
"private/config.rkt"
|
|
"private/http-util.rkt"
|
|
"private/setup.rkt"
|
|
"private/storage.rkt"
|
|
"private/version.rkt"
|
|
"translate.rkt")
|
|
|
|
(provide start-wiki-server)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (user->jsexpr user)
|
|
(hash 'id (wiki-user-id user)
|
|
'username (wiki-user-username user)
|
|
'displayName (wiki-user-display-name user)
|
|
'role (symbol->string (wiki-user-role user))
|
|
'enabled (wiki-user-enabled? user)))
|
|
|
|
(define (session->jsexpr session)
|
|
(if session
|
|
(hash 'authenticated #t
|
|
'user (user->jsexpr (wiki-session-user session))
|
|
'csrfToken (wiki-session-csrf-token session))
|
|
(hash 'authenticated #f)))
|
|
|
|
(define (require-role config req role proc)
|
|
(define session (session-from-request config req))
|
|
(cond
|
|
((not session) (json-error 401 "Authentication required"))
|
|
((not (role-at-least? (wiki-session-user session) role))
|
|
(json-error 403 "Insufficient permissions"))
|
|
(else (proc session))))
|
|
|
|
(define (require-write-role config req role proc)
|
|
(require-role
|
|
config req role
|
|
(λ (session)
|
|
(define csrf (request-header/string req "X-CSRF-Token"))
|
|
(if (csrf-valid? session csrf)
|
|
(proc session)
|
|
(json-error 403 "Invalid CSRF token")))))
|
|
|
|
(define (session-cookie-header config session)
|
|
(define cookie
|
|
(cookie:make-cookie "racket-wiki-session"
|
|
(wiki-session-token session)
|
|
#:path "/"
|
|
#:max-age (wiki-config-session-seconds config)
|
|
#:http-only? #t
|
|
#:secure? (wiki-config-secure-cookie? config)
|
|
#:extension "SameSite=Strict"))
|
|
(make-header #"Set-Cookie"
|
|
(cookie:cookie->set-cookie-header cookie)))
|
|
|
|
(define (login-handler config req)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define body (request-json req))
|
|
(define username (hash-ref body 'username ""))
|
|
(define password (hash-ref body 'password ""))
|
|
(define user (authenticate-user config username password))
|
|
(cond
|
|
((not user) (json-error 401 "Invalid username or password"))
|
|
(else
|
|
(define session (create-session! config user))
|
|
(json-response
|
|
(session->jsexpr session)
|
|
#:headers (list (session-cookie-header config session)))))))
|
|
|
|
(define login-style
|
|
#<<CSS
|
|
html { box-sizing: border-box; font-family: system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", sans-serif; color: #172033; background: #f4f6f8; }
|
|
*, *::before, *::after { box-sizing: inherit; }
|
|
body { margin: 0; min-height: 100vh; display: grid; place-items: center; padding: 32px; }
|
|
.login { width: min(440px, 100%); background: white; border: 1px solid #d7dde5; border-radius: 14px; padding: 34px; box-shadow: 0 12px 40px rgba(22, 32, 51, 0.08); }
|
|
h1 { margin: 0 0 24px; font-size: 2rem; }
|
|
label { display: block; margin: 16px 0; font-weight: 600; }
|
|
input { display: block; width: 100%; margin-top: 6px; padding: 10px 12px; font: inherit; border: 1px solid #aeb7c4; border-radius: 6px; }
|
|
button { margin-top: 2px; padding: 9px 14px; font: inherit; cursor: pointer; }
|
|
.error { margin: 0 0 18px; padding: 12px 14px; background: #fff1f1; border: 1px solid #e8b7b7; border-radius: 6px; color: #8b1f1f; }
|
|
CSS
|
|
)
|
|
|
|
(define (request-form req)
|
|
(define body (request-post-data/raw req))
|
|
(if body
|
|
(form-urlencoded->alist (bytes->string/utf-8 body))
|
|
'()))
|
|
|
|
(define (form-value form key [default ""])
|
|
(define found (assoc key form))
|
|
(if (and found (cdr found))
|
|
(cdr found)
|
|
default))
|
|
|
|
(define (login-page config [message #f] [username ""])
|
|
`(html
|
|
(head
|
|
(meta ((charset "utf-8")))
|
|
(meta ((name "viewport") (content "width=device-width, initial-scale=1")))
|
|
(title ,(string-append (tr config 'sign-in) " - " (wiki-config-site-title config)))
|
|
(style ,login-style))
|
|
(body
|
|
(main ((class "login"))
|
|
(h1 ,(tr config 'sign-in))
|
|
,@(if message
|
|
`((div ((class "error")) ,message))
|
|
'())
|
|
(form ((method "post") (action "/login"))
|
|
(label
|
|
,(tr config 'username)
|
|
(input ((name "username")
|
|
(value ,username)
|
|
(autocomplete "username")
|
|
(required "required")
|
|
(autofocus "autofocus"))))
|
|
(label
|
|
,(tr config 'password)
|
|
(input ((name "password")
|
|
(type "password")
|
|
(autocomplete "current-password")
|
|
(required "required"))))
|
|
(button ((type "submit")) ,(tr config 'sign-in)))))))
|
|
|
|
(define (login-page-response config [message #f] [username ""])
|
|
(html-response
|
|
(login-page config message username)
|
|
#:code (if message 401 200)
|
|
#:headers (list (make-header #"Cache-Control" #"no-store"))))
|
|
|
|
(define (browser-login-handler config req)
|
|
(define session (session-from-request config req))
|
|
(cond
|
|
(session
|
|
(redirect-response "/"))
|
|
((string-ci=? (bytes->string/latin-1 (request-method req)) "POST")
|
|
(define form (request-form req))
|
|
(define username (string-trim (form-value form 'username)))
|
|
(define password (form-value form 'password))
|
|
(define user (authenticate-user config username password))
|
|
(cond
|
|
((not user)
|
|
(login-page-response config "Invalid username or password" username))
|
|
(else
|
|
(define new-session (create-session! config user))
|
|
(redirect-response
|
|
"/"
|
|
#:headers (list (session-cookie-header config new-session))))))
|
|
(else
|
|
(login-page-response config))))
|
|
|
|
(define (logout-handler config req)
|
|
(require-write-role
|
|
config req 'reader
|
|
(λ (session)
|
|
(delete-session! config (wiki-session-token session))
|
|
(json-response
|
|
(hash 'ok #t)
|
|
#:headers
|
|
(list (make-header #"Set-Cookie"
|
|
(cookie:clear-cookie-header "racket-wiki-session" #:path "/")))))))
|
|
|
|
(define (page-list-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(json-response (hash 'pages (list-pages config)
|
|
'aliases (list-page-aliases config))))))
|
|
|
|
(define (concept-map-list-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(json-response (hash 'conceptMaps (list-concept-maps config))))))
|
|
|
|
(define (request-concept-map-document body)
|
|
(define document (hash-ref body 'document #f))
|
|
(unless (hash? document)
|
|
(raise-argument-error 'request-concept-map-document "hash?" document))
|
|
document)
|
|
|
|
(define (concept-map-create-handler config req)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define body (request-json req))
|
|
(define title (string-trim (hash-ref body 'title "")))
|
|
(define requested-slug (string-trim (hash-ref body 'slug "")))
|
|
(define slug
|
|
(if (string=? requested-slug "")
|
|
(title->slug title)
|
|
requested-slug))
|
|
(define document (request-concept-map-document body))
|
|
(cond
|
|
((string=? title "") (json-error 400 "Title is required"))
|
|
((string=? slug "") (json-error 400 "The title cannot be converted to a concept map address"))
|
|
((read-concept-map config slug)
|
|
(json-error 409 "A concept map with this address already exists"))
|
|
(else
|
|
(json-response
|
|
(create-concept-map! config
|
|
slug
|
|
title
|
|
document
|
|
(wiki-user-username (wiki-session-user session)))
|
|
#:code 201)))))))
|
|
|
|
(define (concept-map-get-handler config req slug)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(define concept-map (read-concept-map config slug))
|
|
(if concept-map
|
|
(json-response concept-map)
|
|
(json-error 404 "Concept map not found")))))
|
|
|
|
(define (concept-map-update-handler config req slug)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail?
|
|
(λ (e)
|
|
(if (string=? (exn-message e) "update-concept-map!: version-conflict")
|
|
(json-error 409 "Concept map changed since it was opened")
|
|
(json-error 400 (exn-message e))))))
|
|
(define body (request-json req))
|
|
(define title (string-trim (hash-ref body 'title "")))
|
|
(define document (request-concept-map-document body))
|
|
(define base-version (hash-ref body 'baseVersion ""))
|
|
(json-response
|
|
(update-concept-map! config
|
|
slug
|
|
title
|
|
document
|
|
(wiki-user-username (wiki-session-user session))
|
|
base-version))))))
|
|
|
|
(define (concept-map-rename-handler config req slug)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail?
|
|
(λ (e)
|
|
(if (string=? (exn-message e) "rename-concept-map!: version-conflict")
|
|
(json-error 409 "Concept map changed since it was opened")
|
|
(json-error 400 (exn-message e))))))
|
|
(define body (request-json req))
|
|
(define title (string-trim (hash-ref body 'title "")))
|
|
(define base-version (hash-ref body 'baseVersion ""))
|
|
(json-response
|
|
(rename-concept-map! config
|
|
slug
|
|
title
|
|
(wiki-user-username (wiki-session-user session))
|
|
base-version))))))
|
|
|
|
(define (concept-map-delete-handler config req slug)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(archive-concept-map! config
|
|
slug
|
|
(wiki-user-username (wiki-session-user session)))
|
|
(json-response (hash 'ok #t))))))
|
|
|
|
(define (request-query-value req key [default ""])
|
|
(define found (assoc key (url-query (request-uri req))))
|
|
(if found (cdr found) default))
|
|
|
|
(define (search-result-before? first-result second-result)
|
|
(define first-rank (hash-ref first-result 'rank 0))
|
|
(define second-rank (hash-ref second-result 'rank 0))
|
|
(if (= first-rank second-rank)
|
|
(string-ci<? (hash-ref first-result 'title "")
|
|
(hash-ref second-result 'title ""))
|
|
(> first-rank second-rank)))
|
|
|
|
(define (recent-result-before? first-result second-result)
|
|
(define first-updated-at (hash-ref first-result 'updatedAt 0))
|
|
(define second-updated-at (hash-ref second-result 'updatedAt 0))
|
|
(if (= first-updated-at second-updated-at)
|
|
(string-ci<? (hash-ref first-result 'title "")
|
|
(hash-ref second-result 'title ""))
|
|
(> first-updated-at second-updated-at)))
|
|
|
|
(define (search-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(define query-text (request-query-value req 'q))
|
|
(define page-results (search-pages config query-text))
|
|
(define concept-map-results (search-concept-maps config query-text))
|
|
(define sorted-results
|
|
(sort (append page-results concept-map-results)
|
|
search-result-before?))
|
|
(define result-count (min 50 (length sorted-results)))
|
|
(json-response
|
|
(hash 'results (take sorted-results result-count))))))
|
|
|
|
(define (todo-list-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(json-response (hash 'items (list-todos config))))))
|
|
|
|
|
|
(define (recent-list-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(define page-results
|
|
(map (λ (page) (hash-set page 'type "page"))
|
|
(list-recent-pages config)))
|
|
(define concept-map-results
|
|
(map (λ (concept-map) (hash-set concept-map 'type "cmap"))
|
|
(list-recent-concept-maps config)))
|
|
(define sorted-results
|
|
(sort (append page-results concept-map-results)
|
|
recent-result-before?))
|
|
(define result-count (min 50 (length sorted-results)))
|
|
(json-response (hash 'items (take sorted-results result-count))))))
|
|
|
|
(define (bookmark-list-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (session)
|
|
(define user-id (wiki-user-id (wiki-session-user session)))
|
|
(json-response (hash 'bookmarks (list-bookmarks config user-id))))))
|
|
|
|
(define (bookmark-save-handler config req)
|
|
(require-write-role
|
|
config req 'reader
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define body (request-json req))
|
|
(define slug (hash-ref body 'slug ""))
|
|
(define section (hash-ref body 'section ""))
|
|
(unless (string? slug)
|
|
(raise-argument-error 'bookmark-save-handler "string?" slug))
|
|
(unless (string? section)
|
|
(raise-argument-error 'bookmark-save-handler "string?" section))
|
|
(define user-id (wiki-user-id (wiki-session-user session)))
|
|
(set-bookmark! config user-id slug section)
|
|
(json-response (hash 'ok #t))))))
|
|
|
|
(define (bookmark-delete-handler config req slug)
|
|
(require-write-role
|
|
config req 'reader
|
|
(λ (session)
|
|
(define user-id (wiki-user-id (wiki-session-user session)))
|
|
(delete-bookmark! config user-id slug)
|
|
(json-response (hash 'ok #t)))))
|
|
|
|
(define (translations-handler config req)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(json-response
|
|
(hash 'language (current-language config)
|
|
'page (translation-page-slug)
|
|
'template (translation-page-template)
|
|
'translations (translations-for config))))))
|
|
|
|
(define (page-get-handler config req slug)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(define page (and (valid-page-reference? slug) (read-page config slug)))
|
|
(if page
|
|
(json-response page)
|
|
(json-error 404 "Page not found")))))
|
|
|
|
(define (request-tags body)
|
|
(define value (hash-ref body 'tags '()))
|
|
(if (and (list? value)
|
|
(for/and ((tag (in-list value)))
|
|
(string? tag)))
|
|
value
|
|
(raise-argument-error 'request-tags "list of strings" value)))
|
|
|
|
(define (page-create-handler config req)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define body (request-json req))
|
|
(define requested-slug (hash-ref body 'slug #f))
|
|
(define namespace (string-trim (hash-ref body 'namespace "")))
|
|
(define title (hash-ref body 'title ""))
|
|
(define markdown (hash-ref body 'markdown ""))
|
|
(define tags (request-tags body))
|
|
(define summary (hash-ref body 'summary "Created page"))
|
|
(define slug
|
|
(cond
|
|
(requested-slug requested-slug)
|
|
((string=? namespace "") (title->slug title))
|
|
(else (page-reference namespace (title->slug title)))))
|
|
(cond
|
|
((string=? (string-trim title) "")
|
|
(json-error 400 "Title is required"))
|
|
((string=? slug "")
|
|
(json-error 400 "The title cannot be converted to a page slug"))
|
|
((not (valid-page-reference? slug))
|
|
(json-error 400 "Invalid page address"))
|
|
((read-page config slug)
|
|
(json-error 409 "A page with this address already exists"))
|
|
(else
|
|
(json-response
|
|
(create-page! config
|
|
slug
|
|
title
|
|
markdown
|
|
(wiki-user-username (wiki-session-user session))
|
|
summary
|
|
tags)
|
|
#:code 201)))))))
|
|
|
|
(define (page-update-handler config req slug)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail?
|
|
(λ (e)
|
|
(if (string=? (exn-message e) "update-page!: version-conflict")
|
|
(json-error 409 "Page changed since it was opened")
|
|
(json-error 400 (exn-message e))))))
|
|
(define body (request-json req))
|
|
(define title (hash-ref body 'title ""))
|
|
(define markdown (hash-ref body 'markdown ""))
|
|
(define tags (request-tags body))
|
|
(define base-version (hash-ref body 'baseVersion ""))
|
|
(define summary (hash-ref body 'summary "Edited page"))
|
|
(json-response
|
|
(update-page! config
|
|
slug
|
|
title
|
|
markdown
|
|
(wiki-user-username (wiki-session-user session))
|
|
base-version
|
|
summary
|
|
tags
|
|
#f))))))
|
|
|
|
(define (page-rename-handler config req reference)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(when (string=? reference (translation-page-slug))
|
|
(error 'page-rename-handler "the translations system page cannot be renamed"))
|
|
(define body (request-json req))
|
|
(define title (string-trim (hash-ref body 'title "")))
|
|
(define namespace (string-trim (hash-ref body 'namespace "")))
|
|
(define slug (string-trim (hash-ref body 'slug "")))
|
|
(define summary (hash-ref body 'summary "Renamed page"))
|
|
(json-response
|
|
(rename-page! config
|
|
reference
|
|
title
|
|
namespace
|
|
slug
|
|
(wiki-user-username (wiki-session-user session))
|
|
summary))))))
|
|
|
|
(define (page-delete-handler config req slug)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(archive-page! config
|
|
slug
|
|
(wiki-user-username (wiki-session-user session)))
|
|
(json-response (hash 'ok #t))))))
|
|
|
|
(define (history-handler config req slug)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 404 (exn-message e)))))
|
|
(json-response (hash 'versions (page-history config slug)))))))
|
|
|
|
(define (version-handler config req slug version)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(define result (read-version config slug version))
|
|
(if result
|
|
(json-response result)
|
|
(json-error 404 "Version not found")))))
|
|
|
|
(define (upload-handler config req slug)
|
|
(require-write-role
|
|
config req 'editor
|
|
(λ (session)
|
|
(define name (or (request-header/string req "X-File-Name") "upload.bin"))
|
|
(define content (or (request-post-data/raw req) #""))
|
|
(cond
|
|
((> (bytes-length content) (* 50 1024 1024))
|
|
(json-error 413 "Upload exceeds 50 MiB"))
|
|
(else
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(json-response (save-upload! config
|
|
slug
|
|
name
|
|
content
|
|
(wiki-user-username (wiki-session-user session)))
|
|
#:code 201)))))))
|
|
|
|
(define (inline-image-mime? mime)
|
|
(if (member mime
|
|
'(#"image/png"
|
|
#"image/jpeg"
|
|
#"image/gif"
|
|
#"image/webp"))
|
|
#t
|
|
#f))
|
|
|
|
(define (upload-file-response attachment)
|
|
(define mime (string->bytes/utf-8 (hash-ref attachment 'mimeType)))
|
|
(define stored-name (hash-ref attachment 'storedName))
|
|
(define original-name (hash-ref attachment 'originalName))
|
|
(define disposition
|
|
(if (inline-image-mime? mime)
|
|
#"inline"
|
|
(string->bytes/utf-8
|
|
(format "attachment; filename=\"~a\"" original-name))))
|
|
(bytes-response
|
|
(hash-ref attachment 'content)
|
|
mime
|
|
#:headers
|
|
(list (make-header #"Content-Disposition" disposition))))
|
|
|
|
(define (upload-get-handler config req slug stored-name)
|
|
(require-role
|
|
config req 'reader
|
|
(λ (_session)
|
|
(define attachment (uploaded-file config slug stored-name))
|
|
(if attachment
|
|
(upload-file-response attachment)
|
|
(json-error 404 "File not found")))))
|
|
|
|
(define (admin-orphaned-uploads-handler config req)
|
|
(require-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(json-response (hash 'uploads (list-orphaned-uploads config))))))
|
|
|
|
(define (admin-delete-orphaned-upload-handler config req id)
|
|
(require-write-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(delete-orphaned-upload! config id)
|
|
(json-response (hash 'ok #t))))))
|
|
|
|
(define (admin-info-handler config req)
|
|
(require-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(json-response (hash 'softwareVersion racket-wiki-version)))))
|
|
|
|
(define (admin-page-aliases-handler config req)
|
|
(require-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(json-response (hash 'aliases (list-page-alias-details config))))))
|
|
|
|
|
|
(define (admin-cleanup-page-alias-handler config req id)
|
|
(require-write-role
|
|
config req 'admin
|
|
(λ (session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define author (wiki-user-username (wiki-session-user session)))
|
|
(json-response (cleanup-page-alias! config id author))))))
|
|
|
|
(define (admin-delete-page-alias-handler config req id)
|
|
(require-write-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(delete-page-alias! config id)
|
|
(json-response (hash 'ok #t))))))
|
|
|
|
(define (admin-users-handler config req)
|
|
(require-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(json-response (hash 'users (map user->jsexpr (list-users config)))))))
|
|
|
|
(define (admin-create-user-handler config req)
|
|
(require-write-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define body (request-json req))
|
|
(define username (hash-ref body 'username ""))
|
|
(define display-name (hash-ref body 'displayName username))
|
|
(define password (hash-ref body 'password ""))
|
|
(define role (string->symbol (hash-ref body 'role "reader")))
|
|
(define status (if (hash-ref body 'enabled #t) 'enabled 'disabled))
|
|
(unless (member role '(reader editor admin))
|
|
(error 'admin-create-user-handler "Invalid role"))
|
|
(when (or (string=? username "") (string=? password ""))
|
|
(error 'admin-create-user-handler "Username and password are required"))
|
|
(create-user! config username display-name password role status)
|
|
(json-response (hash 'ok #t) #:code 201)))))
|
|
|
|
(define (admin-update-user-handler config req id)
|
|
(require-write-role
|
|
config req 'admin
|
|
(λ (_session)
|
|
(with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
|
|
(define body (request-json req))
|
|
(define display-name (hash-ref body 'displayName ""))
|
|
(define role (string->symbol (hash-ref body 'role "reader")))
|
|
(define status (if (hash-ref body 'enabled #t) 'enabled 'disabled))
|
|
(define password (hash-ref body 'password #f))
|
|
(unless (member role '(reader editor admin))
|
|
(error 'admin-update-user-handler "Invalid role"))
|
|
(update-user! config id display-name role status password)
|
|
(json-response (hash 'ok #t))))))
|
|
|
|
(define (admin-delete-user-handler config req id)
|
|
(require-write-role
|
|
config req 'admin
|
|
(λ (session)
|
|
(if (= id (wiki-user-id (wiki-session-user session)))
|
|
(json-error 400 "You cannot delete your own account")
|
|
(begin
|
|
(delete-user! config id)
|
|
(json-response (hash 'ok #t)))))))
|
|
|
|
(define (request-path-string req)
|
|
(define segments
|
|
(for/list ([segment (in-list (url-path (request-uri req)))])
|
|
(path/param-path segment)))
|
|
(string-append "/" (string-join segments "/")))
|
|
|
|
(define (index-response)
|
|
(define cmap-cache-id (number->string (random 1000000000)))
|
|
(define index-html
|
|
(file->string (build-path static-directory "index.html")))
|
|
(define cache-busted-index-html
|
|
(string-replace index-html "__CMAP_CACHE_ID__" cmap-cache-id))
|
|
(bytes-response
|
|
(string->bytes/utf-8 cache-busted-index-html)
|
|
#"text/html; charset=utf-8"
|
|
#:headers (list (make-header #"Cache-Control" #"no-cache"))))
|
|
|
|
(define (static-request-path? path)
|
|
(or (regexp-match? #px"^/(vendor|cmap|css|js)/" path)
|
|
(string=? path "/favicon.ico")))
|
|
|
|
(define (application-api-path? path)
|
|
(or (regexp-match? #px"^/api(/|$)" path)
|
|
(regexp-match? #px"^/uploads(/|$)" path)))
|
|
|
|
(define (request-page-slug path)
|
|
(define match (regexp-match #px"^/([^/]+)/?$" path))
|
|
(if match
|
|
(list-ref match 1)
|
|
#f))
|
|
|
|
(define (page-location slug)
|
|
(string-append "/#/" (uri-path-segment-unreserved-encode slug)))
|
|
|
|
(define (not-found-response config)
|
|
(html-response
|
|
`(html
|
|
(head
|
|
(meta ((charset "utf-8")))
|
|
(meta ((name "viewport") (content "width=device-width, initial-scale=1")))
|
|
(title ,(string-append "Not found - " (wiki-config-site-title config))))
|
|
(body
|
|
(h1 "Page not found")))
|
|
#:code 404
|
|
#:headers (list (make-header #"Cache-Control" #"no-store"))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Start the HTTP server for the wiki.
|
|
; pre : config is initialized and its static and data paths are available.
|
|
; post : The server is listening until the servlet environment stops. When
|
|
; initial setup is incomplete, normal application requests redirect
|
|
; to /setup.
|
|
; result : The result returned by serve/servlet.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (start-wiki-server config)
|
|
(define-values (application-dispatch _url)
|
|
(dispatch-rules
|
|
[("api" "session") #:method "get"
|
|
(λ (req)
|
|
(json-response
|
|
(session->jsexpr (session-from-request config req))))]
|
|
[("api" "login") #:method "post"
|
|
(λ (req) (login-handler config req))]
|
|
[("api" "logout") #:method "post"
|
|
(λ (req) (logout-handler config req))]
|
|
[("api" "ping") #:method "get"
|
|
(λ (_req) (json-response (hash 'ok #t 'time (current-seconds))))]
|
|
[("api" "translations") #:method "get"
|
|
(λ (req) (translations-handler config req))]
|
|
[("api" "todos") #:method "get"
|
|
(λ (req) (todo-list-handler config req))]
|
|
[("api" "recent") #:method "get"
|
|
(λ (req) (recent-list-handler config req))]
|
|
[("api" "bookmarks") #:method "get"
|
|
(λ (req) (bookmark-list-handler config req))]
|
|
[("api" "bookmarks") #:method "post"
|
|
(λ (req) (bookmark-save-handler config req))]
|
|
[("api" "bookmarks" (string-arg)) #:method "delete"
|
|
(λ (req slug) (bookmark-delete-handler config req slug))]
|
|
[("api" "search") #:method "get"
|
|
(λ (req) (search-handler config req))]
|
|
[("api" "pages") #:method "get"
|
|
(λ (req) (page-list-handler config req))]
|
|
[("api" "cmaps") #:method "get"
|
|
(λ (req) (concept-map-list-handler config req))]
|
|
[("api" "cmaps") #:method "post"
|
|
(λ (req) (concept-map-create-handler config req))]
|
|
[("api" "cmaps" (string-arg)) #:method "get"
|
|
(λ (req slug) (concept-map-get-handler config req slug))]
|
|
[("api" "cmaps" (string-arg)) #:method "put"
|
|
(λ (req slug) (concept-map-update-handler config req slug))]
|
|
[("api" "cmaps" (string-arg) "rename") #:method "post"
|
|
(λ (req slug) (concept-map-rename-handler config req slug))]
|
|
[("api" "cmaps" (string-arg)) #:method "delete"
|
|
(λ (req slug) (concept-map-delete-handler config req slug))]
|
|
[("api" "pages") #:method "post"
|
|
(λ (req) (page-create-handler config req))]
|
|
[("api" "pages" (string-arg)) #:method "get"
|
|
(λ (req slug) (page-get-handler config req slug))]
|
|
[("api" "pages" (string-arg)) #:method "put"
|
|
(λ (req slug) (page-update-handler config req slug))]
|
|
[("api" "pages" (string-arg) "rename") #:method "post"
|
|
(λ (req slug) (page-rename-handler config req slug))]
|
|
[("api" "pages" (string-arg)) #:method "delete"
|
|
(λ (req slug) (page-delete-handler config req slug))]
|
|
[("api" "pages" (string-arg) "history") #:method "get"
|
|
(λ (req slug) (history-handler config req slug))]
|
|
[("api" "pages" (string-arg) "versions" (string-arg)) #:method "get"
|
|
(λ (req slug version) (version-handler config req slug version))]
|
|
[("api" "pages" (string-arg) "upload") #:method "post"
|
|
(λ (req slug) (upload-handler config req slug))]
|
|
[("uploads" (string-arg) (string-arg)) #:method "get"
|
|
(λ (req slug stored-name) (upload-get-handler config req slug stored-name))]
|
|
[("api" "admin" "info") #:method "get"
|
|
(λ (req) (admin-info-handler config req))]
|
|
[("api" "admin" "aliases") #:method "get"
|
|
(λ (req) (admin-page-aliases-handler config req))]
|
|
[("api" "admin" "aliases" (integer-arg) "cleanup") #:method "post"
|
|
(λ (req id) (admin-cleanup-page-alias-handler config req id))]
|
|
[("api" "admin" "aliases" (integer-arg)) #:method "delete"
|
|
(λ (req id) (admin-delete-page-alias-handler config req id))]
|
|
[("api" "admin" "uploads" "orphaned") #:method "get"
|
|
(λ (req) (admin-orphaned-uploads-handler config req))]
|
|
[("api" "admin" "uploads" "orphaned" (integer-arg)) #:method "delete"
|
|
(λ (req id) (admin-delete-orphaned-upload-handler config req id))]
|
|
[("api" "admin" "users") #:method "get"
|
|
(λ (req) (admin-users-handler config req))]
|
|
[("api" "admin" "users") #:method "post"
|
|
(λ (req) (admin-create-user-handler config req))]
|
|
[("api" "admin" "users" (integer-arg)) #:method "put"
|
|
(λ (req id) (admin-update-user-handler config req id))]
|
|
[("api" "admin" "users" (integer-arg)) #:method "delete"
|
|
(λ (req id) (admin-delete-user-handler config req id))]
|
|
[else (λ (_req) (json-error 404 "API endpoint not found"))]))
|
|
|
|
(define setup-ready? (box (setup-complete? config)))
|
|
|
|
(define (dispatch req)
|
|
(define path (request-path-string req))
|
|
(cond
|
|
((regexp-match? #px"^/setup/?$" path)
|
|
(define response (setup-handler config req))
|
|
(when (setup-complete? config)
|
|
(set-box! setup-ready? #t))
|
|
response)
|
|
((not (unbox setup-ready?))
|
|
(redirect-response "/setup"))
|
|
((regexp-match? #px"^/login/?$" path)
|
|
(browser-login-handler config req))
|
|
((static-request-path? path)
|
|
(next-dispatcher))
|
|
((application-api-path? path)
|
|
(application-dispatch req))
|
|
((or (string=? path "/")
|
|
(string=? path "/index.html"))
|
|
(if (session-from-request config req)
|
|
(index-response)
|
|
(redirect-response "/login")))
|
|
(else
|
|
(define session (session-from-request config req))
|
|
(define slug (request-page-slug path))
|
|
(cond
|
|
((not session)
|
|
(redirect-response "/login"))
|
|
((and slug (valid-page-reference? slug))
|
|
(let ((page (read-page config slug)))
|
|
(cond
|
|
(page
|
|
(redirect-response (page-location slug)))
|
|
((role-at-least? (wiki-session-user session) 'editor)
|
|
(redirect-response (page-location slug)))
|
|
(else
|
|
(not-found-response config)))))
|
|
(else
|
|
(not-found-response config))))))
|
|
|
|
(displayln
|
|
(format "~a listening on http://~a:~a/"
|
|
(wiki-config-site-title config)
|
|
(or (wiki-config-listen-ip config) "0.0.0.0")
|
|
(wiki-config-port config)))
|
|
|
|
(when (not (unbox setup-ready?))
|
|
(displayln "Initial setup is required. Open /setup in a browser."))
|
|
|
|
(serve/servlet dispatch
|
|
#:launch-browser? #f
|
|
#:quit? #f
|
|
#:banner? #f
|
|
#:listen-ip (wiki-config-listen-ip config)
|
|
#:port (wiki-config-port config)
|
|
#:servlet-regexp #rx""
|
|
#:extra-files-paths (list (data-static-directory config)
|
|
static-directory)))
|