diff options
Diffstat (limited to 'module/calp/server/routes.scm')
| -rw-r--r-- | module/calp/server/routes.scm | 228 |
1 files changed, 114 insertions, 114 deletions
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 2f3544ee..d05451eb 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -1,14 +1,13 @@ (define-module (calp server routes) :use-module (hnh util) - :use-module ((hnh util path) :select (path-append)) - :use-module (hnh util options) + :use-module (hnh util path) :use-module (hnh util exceptions) :use-module (srfi srfi-1) :use-module ((ice-9 rdelim) :select (read-string)) :use-module ((ice-9 ftw) :select (scandir)) - :use-module (ice-9 regex) #| regex here due to bad macros |# + :use-module (ice-9 format) :use-module ((web response) :select (build-response)) :use-module ((web uri) :select (build-relative-ref)) @@ -32,6 +31,7 @@ :autoload (vcomponent util instance) (global-event-object) + :use-module (calp util config) :use-module (calp html view calendar) :use-module ((calp html view search) :select (search-result-page)) @@ -47,27 +47,50 @@ -(define (directory-table dir) - `(table - (thead - (tr (th "") (th ,(_ "Name")) - ;; File permissions, should be about as long as three digits - (th ,(_ "Perm")))) +;; @var{prefix} directory tree which should be exported +;; @var{dir} location in exported directory tree +;; Note that the exported url is currently hard-coded to +;; start with /static. +(define (directory-table prefix dir) + `(table (@ (class "directory-table")) + (thead + (tr (th "") + (th ,(_ "Name")) + ;; File permissions, should be about as long as three digits + (th ,(_ "Perm")) + ;; File size + (th ,(_ "Size")))) (tbody + (tr (td "âŠī¸") (td (@ (colspan 3)) + (a (@ (href ,(-> (path-split dir) + (drop-right 1) + (xcons "/static") + path-join))) + "Return up"))) ,@(map (lambda (k) - (let* ((stat (lstat (path-append dir k)))) + (let* ((stat (lstat (path-append prefix dir k)))) `(tr (td ,(case (stat:type stat) [(directory) "đ"] [(regular) "đ°"] + [(symlink) "đ"] + [(block-special) "đ´"] + [(char-special) "đ"] + ;; [(fifo)] + ;; [(socket)] [else "đ"])) - (td (a (@ (href "/" ,dir "/" ,k)) ,k)) - (td ,(number->string (stat:perms stat) 8))))) - (cdr (or (scandir dir) - (scm-error - 'misc-error - "directory-table" - (_ "Scandir argument invalid or not directory: ~a") - (list dir) '()))))))) + (td (a (@ (href ,(path-append "/static" dir k))) + ,k)) + (td ,(number->string (stat:perms stat) 8)) + (td (@ (style "text-align:end")) + (data (@ (value ,(stat:size stat))) + ,(format #f "~:d" (stat:size stat))))))) + ;; cddr drops '.' and '..' + (cddr (or (scandir (path-append prefix dir)) + (scm-error + 'misc-error + "directory-table" + (_ "Scandir argument invalid or not directory: ~s") + (list dir) '()))))))) @@ -88,6 +111,14 @@ +(define static-dir (make-parameter "static")) + +(define-config static-dir "static" + description: "Where static files for the web server are located" + post: static-dir + ) + + ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats @@ -234,70 +265,22 @@ ;; accidental overwriting. - (cond - [(get-event-by-uid global-event-object (prop event 'UID)) - => (lambda (old-event) - - ;; remove old instance of event from runtime - ((@ (vcomponent util instance methods) remove-event) - global-event-object old-event) - - ;; Add new event to runtime, - ;; MUST be done after since the two events SHOULD share UID. - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - (set! (prop event 'LAST-MODIFIED) - (current-datetime)) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - - ;; save-event sets -X-HNH-FILENAME from the UID. This is fine - ;; since the two events are guaranteed to have the same UID. - (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (return (build-response code: 500) - (_ "Saving event to disk failed."))) - - - (unless (eq? calendar (parent old-event)) - ;; change to a new calendar - (format (current-error-port) - ;; unlinks (removes) a single event, argument is a file name - (_ "Unlinking old event from ~a~%") - (prop old-event '-X-HNH-FILENAME)) - ;; NOTE that this may fail, leading to a duplicate event being - ;; created (since we save beforehand). This is just a minor problem - ;; which either a better atomic model, or a propper error - ;; recovery log would solve. - ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) - - - (format (current-error-port) - (_ "Event updated ~a~%") (prop event 'UID)))] - - [else - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - (set! (prop event 'LAST-MODIFIED) (current-datetime)) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (return (build-response code: 500) - (_ "Saving event to disk failed."))) - - (format (current-error-port) - (_ "Event inserted ~a~%") (prop event 'UID))]) + (parameterize ((warnings-are-errors #t)) + (catch* + (lambda () (add-and-save-event global-event-object + calendar event)) + (warning + (lambda (err fmt args) + (define str (format #f "~?" fmt args)) + (format (current-error-port) "400 ~a~%" str) + (return (build-response code: 400) + str))) + (#t + (lambda (err proc fmt args _) + (define str (format #f "~a in ~a: ~?~%" err proc fmt args)) + (format (current-error-port) "500 ~a~%" str) + (return (build-response code: 500) + str))))) (return '((content-type application/xml)) (with-output-to-string @@ -395,28 +378,27 @@ (define error #f) (define search-result - (catch #t - (lambda () - (catch 'max-page - ;; TODO Get-page only puts a time limiter per page, meaning that - ;; if a user requests page 1000 the server is stuck trying to - ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ - ;; A timeout here, and also an actual multithreaded server should - ;; solve this. - (lambda () (get-page paginator page)) - (lambda (err page-number) - (define location - (build-relative-ref - path: r:path ; host: r:host port: r:port - query: (encode-query-parameters - `((p . ,page-number) - (q . ,search-term))))) - (return (build-response - code: 307 - headers: `((location . ,location))))))) - (lambda (err callee fmt arg data) - (set! error - (format #f "~?~%" fmt arg))))) + ;; TODO Get-page only puts a time limiter per page, meaning that + ;; if a user requests page 1000 the server is stuck trying to + ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ + ;; A timeout here, and also an actual multithreaded server should + ;; solve this. + (catch* (lambda () (get-page paginator page)) + (max-page + (lambda (err page-number) + (define location + (build-relative-ref + path: r:path ; host: r:host port: r:port + query: (encode-query-parameters + `((p . ,page-number) + (q . ,search-term))))) + (return (build-response + code: 307 + headers: `((location . ,location)))))) + (#t + (lambda (err callee fmt arg data) + (set! error + (format #f "~?~%" fmt arg)))))) (return '((content-type application/xhtml+xml)) (with-output-to-string @@ -431,6 +413,7 @@ ;; is mostly for development, and something like nginx should be used in ;; production it isn't a huge problem. + (GET "/static/:*{.*}.:ext" (* ext) ;; Actually parsing /etc/mime.types would be better. @@ -439,16 +422,33 @@ [(js) "javascript"] [else ext])) - (return - `((content-type ,(string->symbol (string-append "text/" mime)))) - (call-with-input-file (string-append "static/" * "." ext) - read-string))) - - (GET "/static/:*{.*}" (*) - (return - '((content-type text/html)) - (sxml->html-string - (directory-table (path-append "static" *))))) + (catch 'system-error + (lambda () + (return + `((content-type ,(string->symbol (string-append "text/" mime)))) + (call-with-input-file (path-append (static-dir) (string-append * "." ext)) + read-string))) + (lambda (err proc fmt fmt-args data) + (warning (format #f "404|500: ~?" fmt fmt-args)) + (if (= ENOENT (car data)) + (return (build-response code: 404) + (format #f "~?" fmt fmt-args)) + (scm-error err proc fmt fmt-args data))))) + + ;; Note that `path' will most likely start with a slash + (GET "/static:path{.*}" (path) + (catch + 'misc-error + (lambda () (return + '((content-type text/html)) + (sxml->html-string + `(html + (head (title "Calp directory listing for " path) + ,((@ (calp html components) include-css) "/static/directory-listing.css")) + (body ,(directory-table (static-dir) path)))))) + (lambda (err proc fmt fmt-args data) + (return (build-response code: 404) + (format #f "~?" fmt fmt-args))))) ;; This is almost the same as /static/, but with the difference that ;; we produce these images during runtime |