diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-12 07:10:08 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-12 07:10:08 +0200 |
| commit | 241ad632399e1e1f136b4e84fb3b4624897bf154 (patch) | |
| tree | 3bd9c0f48503477c492ac3a75ae37939a7fa1b4b | |
| parent | Slightly clean up server imports. (diff) | |
| download | calp-241ad632399e1e1f136b4e84fb3b4624897bf154.tar.gz calp-241ad632399e1e1f136b4e84fb3b4624897bf154.tar.xz | |
Broke away routes from server entry-points.
| -rw-r--r-- | module/entry-points/server.scm | 350 | ||||
| -rw-r--r-- | module/server/macro.scm | 63 | ||||
| -rw-r--r-- | module/server/routes.scm | 362 |
3 files changed, 403 insertions, 372 deletions
diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index ec9d3c3f..76cdc7d1 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -4,363 +4,27 @@ :use-module (util exceptions) :use-module (srfi srfi-1) - :use-module (srfi srfi-17) - :use-module (ice-9 match) - :use-module (ice-9 control) - :use-module ((ice-9 rdelim) :select (read-string)) - :use-module ((ice-9 ftw) :select (scandir)) :use-module (ice-9 getopt-long) :use-module (ice-9 regex) #| regex here due to bad macros |# - :use-module (web server) - :use-module (web request) - :use-module (web response) - :use-module (web uri) - :use-module (web http) + :use-module ((web server) :select (run-server)) - :use-module (sxml simple) - :use-module (sxml xpath) - :use-module (sxml namespace) - - :use-module (server util) - :use-module (server macro) - - :use-module (vcomponent) - :use-module (vcomponent search) - :use-module (datetime) + ;; :use-module (vcomponent) + ;; :use-module (vcomponent search) + ;; :use-module (datetime) ;; :use-module (output html) - :use-module (output ical) - - :autoload (vcomponent instance) (global-event-object) + ;; :use-module (output ical) - :use-module (html view calendar) - :use-module ((html view search) :select (search-result-page)) + :use-module ((server routes) :select (make-make-routes)) :export (main) ) -(define (sxml->html-string sxml) - (with-output-to-string - (lambda () (display "<!doctype html>\n") (sxml->xml sxml)))) - -(define (// . args) (string-join args file-name-separator-string )) - -(define (directory-table dir) - `(table - (thead - (tr (th "") (th "Name") (th "Perm"))) - (tbody - ,@(map (lambda (k) - (let* ((stat (lstat (// dir k)))) - `(tr (td ,(case (stat:type stat) - [(directory) "📁"] - [(regular) "📰"] - [else "🙃"])) - (td (a (@ (href "/" ,dir "/" ,k)) ,k)) - (td ,(number->string (stat:perms stat) 8))))) - (cdr (scandir dir)))))) - -(define get-query-page - ;; A user of the website is able to fill up all of the hosts memory by - ;; requesting a bunch of different search pages, and forcing a bunch - ;; of pages on each. Clean up this table from time to time, possibly - ;; by popularity-rank. - (let ((query-pages (make-hash-table))) - (lambda (search-term) - (aif (hash-ref query-pages search-term) - it - (let* ((q (prepare-query - (build-query-proc search-term) - (get-event-set global-event-object)))) - (hash-set! query-pages search-term q) - q))))) - - - - -;; TODO ensure encoding on all fields which take user provided data. -;; Possibly a fallback which strips everything unknown, and treats -;; the bytevector as ascii. -(define (make-make-routes) - (make-routes - - ;; Manual redirect to not reserve root. - (GET "/" () - (return '((content-type text/html)) - (sxml->html-string '(a (@ (href "/today")) "Gå till idag")))) - - (GET "/favicon.ico" () - (return - `((content-type image/svg+xml)) - (call-with-input-file "static/calendar.svg" read-string))) - - ;; TODO any exception in this causes the whole page to fail - ;; It would be much better if most of the page could still make it. - (GET "/week/:start-date.html" (start-date) - (let* ((start-date - (start-of-week (parse-iso-date start-date)))) - - (return `((content-type application/xhtml+xml)) - (with-output-to-string - (lambda () - (html-generate calendars: (get-calendars global-event-object) - events: (get-event-set global-event-object) - start-date: start-date - end-date: (date+ start-date (date day: 6)) - next-start: (lambda (d) (date+ d (date day: 7))) - prev-start: (lambda (d) (date- d (date day: 7))) - render-calendar: (@ (html view calendar week) render-calendar) - intervaltype: 'week - )))))) - - (GET "/month/:start-date.html" (start-date) - (let* ((start-date (start-of-month (parse-iso-date start-date)))) - - (return '((content-type application/xhtml+xml)) - (with-output-to-string - (lambda () - (html-generate calendars: (get-calendars global-event-object) - events: (get-event-set global-event-object) - start-date: start-date - end-date: (date- (month+ start-date) - (date day: 1)) - next-start: month+ - prev-start: month- - render-calendar: (@ (html view calendar month) - render-calendar-table) - pre-start: (start-of-week start-date) - post-end: (end-of-week (end-of-month start-date)) - intervaltype: 'month - )))))) - - - (POST "/remove" (uid) - (unless uid - (return (build-response code: 400) - "uid required")) - - (aif (get-event-by-uid global-event-object uid) - (begin - ;; It's hard to properly remove a file. I also want a way to undo accidental - ;; deletions. Therefore I simply save the X-HNH-REMOVED flag to the file, and - ;; then simple don't use those events when loading. - (catch 'stack-overflow (lambda () (remove-event global-event-object it)) - (lambda _ - (display "It overflew...\n" (current-error-port)) - (return (build-response code: 500) - "It overflew again..."))) - (set! (prop it 'X-HNH-REMOVED) #t) - (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") - (unless ((@ (output vdir) save-event) it) - (return (build-response code: 500) - "Saving event to disk failed.")) - (return (build-response code: 204) "")) - (return (build-response code: 400) - (format #f "No event with UID '~a'" uid)))) - - ;; TODO this fails when dtstart is <date>. - ;; TODO If data has an explicit UID and that UID already exists we - ;; overwrite it in the database. We however don't remove the old - ;; event from the in-memory set, but rather just adds the new. - (POST "/insert" (cal data) - - (unless (and cal data) - (return (build-response code: 400) - "Both 'cal' and 'data' required\r\n")) - - - ;; NOTE that this leaks which calendar exists, - ;; but you can only query for existance. - ;; also, the default output gives everything. - (let ((calendar - (find (lambda (c) (string=? cal (prop c 'NAME))) - (get-calendars global-event-object)))) - - (unless calendar - (return (build-response code: 400) - (format #f "No calendar with name [~a]\r\n" cal))) - - ;; Expected form of data (but in XML) is: - ;; @example - ;; (*TOP* - ;; (*PI* ...) - ;; (icalendar (@ (xmlns "...")) - ;; (vcalendar - ;; (vevent ...)))) - ;; @end example - ;; However, *PI* will probably be omited, and currently events - ;; are sent without the vcalendar part. Earlier versions - ;; Also omitted the icalendar part. And I'm not sure if the - ;; *TOP* node is a required part of the sxml. - - (let ((event - ((@ (vcomponent parse xcal) sxcal->vcomponent) - (catch 'parser-error - (lambda () - (move-to-namespace - ;; TODO Multiple event components - (car ((sxpath '(// IC:vevent)) - (xml->sxml data namespaces: '((IC . "urn:ietf:params:xml:ns:icalendar-2.0"))))) - #f)) - (lambda (err port . args) - (return (build-response code: 400) - (format #f "XML parse error ~{~a~}\r\n" args))))))) - - (unless (eq? 'VEVENT (type event)) - (return (build-response code: 400) - "Object not a VEVENT\r\n")) - - ;; NOTE add-event uses the given UID if one is given, - ;; but generates its own if not. It might be a good idea - ;; to require that UID is unset here, and force users - ;; to use a /update endpoint to change events. This to prevent - ;; accidental overwriting. - - (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))))) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (output vdir) save-event) event) - (return (build-response code: 500) - "Saving event to disk failed.")) - - (format (current-error-port) - "Event inserted ~a~%" (prop event 'UID)) - - (return '((content-type application/xml)) - (with-output-to-string - (lambda () - (sxml->xml - `(properties - (uid (text ,(prop event 'UID))))))))))) - - ;; Get specific page by query string instead of by path. - ;; Useful for <form>'s, since they always submit in this form, but also - ;; useful when javascript is disabled, since a link to "today" needs some - ;; form of evaluation when clicked. - (GET "/today" (view date) - (define location - (build-relative-ref - path: - (format #f "/~a/~a.html" - (or view "week") - (date->string - (cond [date => parse-iso-date] - [else (current-date)]) - "~1"))) ) - - (return (build-response - code: 302 - headers: `((location . ,location))))) - - (GET "/calendar" (start end) - (return '((content-type text/calendar)) - (with-output-to-string - (lambda () - (if (or start end) - (print-events-in-interval - (aif start (parse-iso-date it) (current-date)) - (aif end (parse-iso-date it) (current-date))) - (print-all-events)))))) - - (GET "/calendar/:uid{.*}.xcs" (uid) - (aif (get-event-by-uid global-event-object uid) - (return '((content-type application/calendar+xml)) - ;; TODO sxml->xml takes a port, would be better - ;; to give it the return port imidiately. - (with-output-to-string - ;; TODO this is just the vevent part. - ;; A surounding vcalendar is required, as well as - ;; a doctype. - ;; Look into changing how events carry around their - ;; parent information, possibly splitting "source parent" - ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (output xcal) vcomponent->sxcal) it))))) - (return (build-response code: 404) - (format #f "No component with UID=~a found." uid)))) - - (GET "/calendar/:uid{.*}.ics" (uid) - (aif (get-event-by-uid global-event-object uid) - (return '((content-type text/calendar)) - (with-output-to-string - (lambda () (print-components-with-fake-parent - (list it))))) - (return (build-response code: 404) - (format #f "No component with UID=~a found." uid)))) - - ;; TODO search without query should work - (GET "/search" (q p) - (define search-term (prepare-string q)) - - (define q= (find (lambda (s) - (and (<= 2 (string-length s)) - (string=? "q=" (string-take s 2)))) - (string-split r:query #\&))) - - (define paginator (get-query-page search-term)) - - (define page (string->number (or p "0"))) - - ;; TODO Propagate errors - (define search-result - (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: (format #f "~a&p=~a" q= page-number))) - (return (build-response - code: 307 - headers: `((location . ,location))))))) - - (return '((content-type application/xhtml+xml)) - (with-output-to-string - (lambda () - (sxml->xml - (search-result-page - search-term search-result page paginator q=)))))) - - ;; NOTE this only handles files with extensions. Limited, but since this - ;; 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. - (define mime - (case (string->symbol ext) - [(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 (// "static" *))))) + - (GET "/count" () - ;; (sleep 1) - (return '((content-type text/plain)) - (string-append (number->string state) "\n") - (1+ state))))) (define options '((port (value #t) (single-char #\p) diff --git a/module/server/macro.scm b/module/server/macro.scm index 15bc0d0a..2fb87f54 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -63,38 +63,43 @@ (format (current-error-port) "~a~%" request) ;; ALl these bindings generate compile time warnings since the expansion ;; of the macro might not use them. This isn't really a problem. - (let ((r:method (request-method request)) - (r:uri (request-uri request)) - (r:version (request-version request)) - (r:headers (request-headers request)) - (r:meta (request-meta request)) - (r:port (request-port request))) - (let ((r:scheme (uri-scheme r:uri)) - (r:userinfo (uri-userinfo r:uri)) - (r:host (or (uri-host r:uri) (request-host request))) - (r:port (or (uri-port r:uri) (request-port request))) - (r:path (uri-path r:uri)) - (r:query (uri-query r:uri)) - (r:fragment (uri-fragment r:uri))) + (let ((r:method ((@ (web request) request-method) request)) + (r:uri ((@ (web request) request-uri) request)) + (r:version ((@ (web request) request-version) request)) + (r:headers ((@ (web request) request-headers) request)) + (r:meta ((@ (web request) request-meta) request)) + (r:port ((@ (web request) request-port) request))) + (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) + (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) + (r:host (or ((@ (web uri) uri-host) r:uri) + ((@ (web request) request-host) + request))) + (r:port (or ((@ (web uri) uri-port) r:uri) + ((@ (web request) request-port) + request))) + (r:path ((@ (web uri) uri-path) r:uri)) + (r:query ((@ (web uri) uri-query) r:uri)) + (r:fragment ((@ (web uri) uri-fragment) r:uri))) (call-with-values (lambda () - (call/ec (lambda (return) - (apply - (cond ,@(map generate-case routes) - (else (lambda* _ (return (build-response #:code 404) - "404 Not Fonud")))) - (append - (parse-query r:query) + ((@ (ice-9 control) call/ec) + (lambda (return) + (apply + (cond ,@(map generate-case routes) + (else (lambda* _ (return (build-response #:code 404) + "404 Not Fonud")))) + (append + (parse-query r:query) - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type (car content-type)) - (args (cdr content-type))) - (when (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - (parse-query ((@ (ice-9 iconv) bytevector->string) - body encoding) - encoding))))))))))) + (let ((content-type (assoc-ref r:headers 'content-type))) + (when content-type + (let ((type (car content-type)) + (args (cdr content-type))) + (when (eq? type 'application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + (parse-query ((@ (ice-9 iconv) bytevector->string) + body encoding) + encoding))))))))))) (case-lambda ((headers body new-state) (values headers body new-state)) ((headers body) (values headers body state)) ((headers) (values headers "" state)))))))) diff --git a/module/server/routes.scm b/module/server/routes.scm new file mode 100644 index 00000000..fefc9702 --- /dev/null +++ b/module/server/routes.scm @@ -0,0 +1,362 @@ +(define-module (server routes) + :use-module (util) + :use-module (util options) + :use-module (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 ((web response) :select (build-response)) + :use-module ((web uri) :select (build-relative-ref)) + + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module (sxml namespace) + + :use-module (server util) + :use-module (server macro) + + :use-module (vcomponent) + :use-module (vcomponent search) + :use-module (datetime) + ;; :use-module (output html) + :use-module (output ical) + + :autoload (vcomponent instance) (global-event-object) + + :use-module (html view calendar) + :use-module ((html view search) :select (search-result-page)) + + + ) + + + +(define (sxml->html-string sxml) + (with-output-to-string + (lambda () (display "<!doctype html>\n") (sxml->xml sxml)))) + + + +(define (// . args) (string-join args file-name-separator-string )) + +(define (directory-table dir) + `(table + (thead + (tr (th "") (th "Name") (th "Perm"))) + (tbody + ,@(map (lambda (k) + (let* ((stat (lstat (// dir k)))) + `(tr (td ,(case (stat:type stat) + [(directory) "📁"] + [(regular) "📰"] + [else "🙃"])) + (td (a (@ (href "/" ,dir "/" ,k)) ,k)) + (td ,(number->string (stat:perms stat) 8))))) + (cdr (scandir dir)))))) + + + +(define get-query-page + ;; A user of the website is able to fill up all of the hosts memory by + ;; requesting a bunch of different search pages, and forcing a bunch + ;; of pages on each. Clean up this table from time to time, possibly + ;; by popularity-rank. + (let ((query-pages (make-hash-table))) + (lambda (search-term) + (aif (hash-ref query-pages search-term) + it + (let* ((q (prepare-query + (build-query-proc search-term) + (get-event-set global-event-object)))) + (hash-set! query-pages search-term q) + q))))) + + + + +;; TODO ensure encoding on all fields which take user provided data. +;; Possibly a fallback which strips everything unknown, and treats +;; the bytevector as ascii. +(define-public (make-make-routes) + (make-routes + + ;; Manual redirect to not reserve root. + (GET "/" () + (return '((content-type text/html)) + (sxml->html-string '(a (@ (href "/today")) "Gå till idag")))) + + (GET "/favicon.ico" () + (return + `((content-type image/svg+xml)) + (call-with-input-file "static/calendar.svg" read-string))) + + ;; TODO any exception in this causes the whole page to fail + ;; It would be much better if most of the page could still make it. + (GET "/week/:start-date.html" (start-date) + (let* ((start-date + (start-of-week (parse-iso-date start-date)))) + + (return `((content-type application/xhtml+xml)) + (with-output-to-string + (lambda () + (html-generate calendars: (get-calendars global-event-object) + events: (get-event-set global-event-object) + start-date: start-date + end-date: (date+ start-date (date day: 6)) + next-start: (lambda (d) (date+ d (date day: 7))) + prev-start: (lambda (d) (date- d (date day: 7))) + render-calendar: (@ (html view calendar week) render-calendar) + intervaltype: 'week + )))))) + + (GET "/month/:start-date.html" (start-date) + (let* ((start-date (start-of-month (parse-iso-date start-date)))) + + (return '((content-type application/xhtml+xml)) + (with-output-to-string + (lambda () + (html-generate calendars: (get-calendars global-event-object) + events: (get-event-set global-event-object) + start-date: start-date + end-date: (date- (month+ start-date) + (date day: 1)) + next-start: month+ + prev-start: month- + render-calendar: (@ (html view calendar month) + render-calendar-table) + pre-start: (start-of-week start-date) + post-end: (end-of-week (end-of-month start-date)) + intervaltype: 'month + )))))) + + + (POST "/remove" (uid) + (unless uid + (return (build-response code: 400) + "uid required")) + + (aif (get-event-by-uid global-event-object uid) + (begin + ;; It's hard to properly remove a file. I also want a way to undo accidental + ;; deletions. Therefore I simply save the X-HNH-REMOVED flag to the file, and + ;; then simple don't use those events when loading. + (catch 'stack-overflow (lambda () (remove-event global-event-object it)) + (lambda _ + (display "It overflew...\n" (current-error-port)) + (return (build-response code: 500) + "It overflew again..."))) + (set! (prop it 'X-HNH-REMOVED) #t) + (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") + (unless ((@ (output vdir) save-event) it) + (return (build-response code: 500) + "Saving event to disk failed.")) + (return (build-response code: 204) "")) + (return (build-response code: 400) + (format #f "No event with UID '~a'" uid)))) + + ;; TODO this fails when dtstart is <date>. + ;; TODO If data has an explicit UID and that UID already exists we + ;; overwrite it in the database. We however don't remove the old + ;; event from the in-memory set, but rather just adds the new. + (POST "/insert" (cal data) + + (unless (and cal data) + (return (build-response code: 400) + "Both 'cal' and 'data' required\r\n")) + + + ;; NOTE that this leaks which calendar exists, + ;; but you can only query for existance. + ;; also, the default output gives everything. + (let ((calendar + (find (lambda (c) (string=? cal (prop c 'NAME))) + (get-calendars global-event-object)))) + + (unless calendar + (return (build-response code: 400) + (format #f "No calendar with name [~a]\r\n" cal))) + + ;; Expected form of data (but in XML) is: + ;; @example + ;; (*TOP* + ;; (*PI* ...) + ;; (icalendar (@ (xmlns "...")) + ;; (vcalendar + ;; (vevent ...)))) + ;; @end example + ;; However, *PI* will probably be omited, and currently events + ;; are sent without the vcalendar part. Earlier versions + ;; Also omitted the icalendar part. And I'm not sure if the + ;; *TOP* node is a required part of the sxml. + + (let ((event + ((@ (vcomponent parse xcal) sxcal->vcomponent) + (catch 'parser-error + (lambda () + (move-to-namespace + ;; TODO Multiple event components + (car ((sxpath '(// IC:vevent)) + (xml->sxml data namespaces: '((IC . "urn:ietf:params:xml:ns:icalendar-2.0"))))) + #f)) + (lambda (err port . args) + (return (build-response code: 400) + (format #f "XML parse error ~{~a~}\r\n" args))))))) + + (unless (eq? 'VEVENT (type event)) + (return (build-response code: 400) + "Object not a VEVENT\r\n")) + + ;; NOTE add-event uses the given UID if one is given, + ;; but generates its own if not. It might be a good idea + ;; to require that UID is unset here, and force users + ;; to use a /update endpoint to change events. This to prevent + ;; accidental overwriting. + + (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))))) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (output vdir) save-event) event) + (return (build-response code: 500) + "Saving event to disk failed.")) + + (format (current-error-port) + "Event inserted ~a~%" (prop event 'UID)) + + (return '((content-type application/xml)) + (with-output-to-string + (lambda () + (sxml->xml + `(properties + (uid (text ,(prop event 'UID))))))))))) + + ;; Get specific page by query string instead of by path. + ;; Useful for <form>'s, since they always submit in this form, but also + ;; useful when javascript is disabled, since a link to "today" needs some + ;; form of evaluation when clicked. + (GET "/today" (view date) + (define location + (build-relative-ref + path: + (format #f "/~a/~a.html" + (or view "week") + (date->string + (cond [date => parse-iso-date] + [else (current-date)]) + "~1"))) ) + + (return (build-response + code: 302 + headers: `((location . ,location))))) + + (GET "/calendar" (start end) + (return '((content-type text/calendar)) + (with-output-to-string + (lambda () + (if (or start end) + (print-events-in-interval + (aif start (parse-iso-date it) (current-date)) + (aif end (parse-iso-date it) (current-date))) + (print-all-events)))))) + + (GET "/calendar/:uid{.*}.xcs" (uid) + (aif (get-event-by-uid global-event-object uid) + (return '((content-type application/calendar+xml)) + ;; TODO sxml->xml takes a port, would be better + ;; to give it the return port imidiately. + (with-output-to-string + ;; TODO this is just the vevent part. + ;; A surounding vcalendar is required, as well as + ;; a doctype. + ;; Look into changing how events carry around their + ;; parent information, possibly splitting "source parent" + ;; and "program parent" into different fields. + (lambda () (sxml->xml ((@ (output xcal) vcomponent->sxcal) it))))) + (return (build-response code: 404) + (format #f "No component with UID=~a found." uid)))) + + (GET "/calendar/:uid{.*}.ics" (uid) + (aif (get-event-by-uid global-event-object uid) + (return '((content-type text/calendar)) + (with-output-to-string + (lambda () (print-components-with-fake-parent + (list it))))) + (return (build-response code: 404) + (format #f "No component with UID=~a found." uid)))) + + ;; TODO search without query should work + (GET "/search" (q p) + (define search-term (prepare-string q)) + + (define q= (find (lambda (s) + (and (<= 2 (string-length s)) + (string=? "q=" (string-take s 2)))) + (string-split r:query #\&))) + + (define paginator (get-query-page search-term)) + + (define page (string->number (or p "0"))) + + ;; TODO Propagate errors + (define search-result + (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: (format #f "~a&p=~a" q= page-number))) + (return (build-response + code: 307 + headers: `((location . ,location))))))) + + (return '((content-type application/xhtml+xml)) + (with-output-to-string + (lambda () + (sxml->xml + (search-result-page + search-term search-result page paginator q=)))))) + + ;; NOTE this only handles files with extensions. Limited, but since this + ;; 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. + (define mime + (case (string->symbol ext) + [(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 (// "static" *))))) + + + (GET "/count" () + ;; (sleep 1) + (return '((content-type text/plain)) + (string-append (number->string state) "\n") + (1+ state))))) |