From 6461d1b45c7431b36393fd56423298c81f7208ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 17 Aug 2020 18:46:21 +0200 Subject: Split module/server into stuff. --- module/calp/server/routes.scm | 416 +++++++++++++++++++++++++++++++++++++++++ module/calp/server/server.scm | 34 ++++ module/server/macro.scm | 105 ----------- module/server/routes.scm | 417 ------------------------------------------ module/server/server.scm | 34 ---- module/server/test.scm | 76 -------- module/server/util.scm | 17 -- module/web/http/macro.scm | 105 +++++++++++ module/web/query.scm | 16 ++ 9 files changed, 571 insertions(+), 649 deletions(-) create mode 100644 module/calp/server/routes.scm create mode 100644 module/calp/server/server.scm delete mode 100644 module/server/macro.scm delete mode 100644 module/server/routes.scm delete mode 100644 module/server/server.scm delete mode 100644 module/server/test.scm delete mode 100644 module/server/util.scm create mode 100644 module/web/http/macro.scm create mode 100644 module/web/query.scm (limited to 'module') diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm new file mode 100644 index 00000000..afca2d7d --- /dev/null +++ b/module/calp/server/routes.scm @@ -0,0 +1,416 @@ +(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 ((html util) :select (html-unattr)) + + :use-module (web http make-routes) + + :use-module (vcomponent) + :use-module (vcomponent search) + :use-module (datetime) + :use-module (vcomponent ical output) + + :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 "\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 () + (sxml->xml + (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 () + (sxml->xml + (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. + (remove-event global-event-object it) + (set! (prop it 'X-HNH-REMOVED) #t) + (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") + (unless ((@ (vcomponent vdir save-delete) 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 . + ;; @var{cal} should be the name of the calendar encoded with + ;; modified base64. See (html util). + (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 calendar view already show all calendars. + (let* ((calendar-name (html-unattr cal)) + (calendar + (find (lambda (c) (string=? calendar-name (prop c 'NAME))) + (get-calendars global-event-object)))) + + (unless calendar + (return (build-response code: 400) + (format #f "No calendar with name [~a]\r\n" calendar-name))) + + ;; 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 xcal parse) 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. + + + (cond + [(get-event-by-uid global-event-object (prop event 'UID)) + => (lambda (old-event) + + ;; procedure to run after save. + ;; used as hook to remove old event from disk below + (define after-save (const #f)) + + (if (eq? calendar (parent old-event)) + (begin (vcomponent-update! old-event event) + ;; for save below + (set! event old-event)) + + ;; change calendar + (begin + + (format (current-error-port) + "Calendar change~%") + + ;; remove from runtime + ((@ (vcomponent instance methods) remove-event) + global-event-object old-event) + + ;; Actually puring the old event should be safe, + ;; since we first make sure we write the new event to disk. + ;; Currently the whole transaction isn't atomic, so a duplicate + ;; event can still be created. + (set! after-save + ;; remove from disk + (lambda () + (format (current-error-port) + "Unlinking old event from ~a~%" + (prop old-event '-X-HNH-FILENAME)) + ((@ (vcomponent vdir save-delete) remove-event) old-event))) + + (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 ((@ (vcomponent vdir save-delete) save-event) event) + (return (build-response code: 500) + "Saving event to disk failed.")) + + (after-save) + + (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))))) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (vcomponent 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))]) + + (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
'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 ((@ (vcomponent xcal output) 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))))) diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm new file mode 100644 index 00000000..9c857b6d --- /dev/null +++ b/module/calp/server/server.scm @@ -0,0 +1,34 @@ +(define-module (server server) + :use-module (util) + :use-module (web server) + :use-module ((server routes) :select (make-make-routes)) + :use-module (ice-9 threads)) + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +(module-set! + (resolve-module '(web server http)) + 'make-default-socket + (lambda (family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock))) + +(define handler (make-make-routes)) + +;; (define impl (lookup-server-impl 'http)) +;; (define server (open-server impl open-params)) + + +(define-public (start-server open-params) + (run-server handler 'http open-params 1) + ;; NOTE at first this seems to work, but it quickly deteriorates. + ;; (for i in (iota 16) + ;; (begin-thread + ;; (let lp ((state (list 0))) + ;; (lp (serve-one-client handler impl server state))))) + ;; (pause) + ) + + diff --git a/module/server/macro.scm b/module/server/macro.scm deleted file mode 100644 index 41d23d34..00000000 --- a/module/server/macro.scm +++ /dev/null @@ -1,105 +0,0 @@ -(define-module (server macro) - :export (make-routes) - :use-module (util) - :use-module (ice-9 regex) - :use-module (srfi srfi-1) - :use-module (web response) - :use-module (web uri)) - - - -(define-public (parse-endpoint-string str) - (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) - (let loop ((str str) - (string "") - (tokens '())) - (let ((m (regexp-exec rx str 0))) - (if (not m) - ;; done - (values (string-append string str) (reverse tokens)) - - (loop (match:suffix m) - (string-append string (match:prefix m) - (aif (match:substring m 3) - (string-append "(" it ")") - "([^/.]+)") - ;; period directly following matched variable. - ;; since many variables break on period, we often - ;; want to match a literal period directly after them. - ;; Ideally all periods outside of pattern should be - ;; matched literally, but that's harder to implement. - (regexp-quote - (aif (match:substring m 4) - "." ""))) - (cons (string->symbol (match:substring m 1)) - tokens))))))) - -(define (generate-case defn) - (let* (((method uri param-list . body) defn) - (regex tokens (parse-endpoint-string uri)) - (diff intersect (lset-diff+intersection eq? param-list tokens))) - `((and (eq? r:method (quote ,method)) - (regexp-exec (make-regexp ,(string-append "^" regex "/?$") regexp/icase) - r:path)) - => (lambda (match-object) - ;; (assert - ;; (= (1- (match:count match-object)) - ;; (length intersect))) - - ;; Those parameters which were present in the template uri - ((lambda ,intersect - ;; Those that only are in the query string - (lambda* (,@(unless (null? diff) `(#:key ,@diff #:allow-other-keys)) - #:rest rest) - ,@body)) - ,@(unless (null? intersect) - (map (lambda (i) - `(match:substring match-object ,i)) - (cdr (iota (1+ (length intersect))))))))))) - -(define-macro (make-routes . routes) - - `(lambda* (request body #:optional state) - ;; (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 ((@ (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 () - ((@ (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))))))))))) - (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 deleted file mode 100644 index 475e4c43..00000000 --- a/module/server/routes.scm +++ /dev/null @@ -1,417 +0,0 @@ -(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 ((html util) :select (html-unattr)) - - :use-module (server util) - :use-module (server macro) - - :use-module (vcomponent) - :use-module (vcomponent search) - :use-module (datetime) - :use-module (vcomponent ical output) - - :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 "\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 () - (sxml->xml - (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 () - (sxml->xml - (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. - (remove-event global-event-object it) - (set! (prop it 'X-HNH-REMOVED) #t) - (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") - (unless ((@ (vcomponent vdir save-delete) 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 . - ;; @var{cal} should be the name of the calendar encoded with - ;; modified base64. See (html util). - (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 calendar view already show all calendars. - (let* ((calendar-name (html-unattr cal)) - (calendar - (find (lambda (c) (string=? calendar-name (prop c 'NAME))) - (get-calendars global-event-object)))) - - (unless calendar - (return (build-response code: 400) - (format #f "No calendar with name [~a]\r\n" calendar-name))) - - ;; 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 xcal parse) 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. - - - (cond - [(get-event-by-uid global-event-object (prop event 'UID)) - => (lambda (old-event) - - ;; procedure to run after save. - ;; used as hook to remove old event from disk below - (define after-save (const #f)) - - (if (eq? calendar (parent old-event)) - (begin (vcomponent-update! old-event event) - ;; for save below - (set! event old-event)) - - ;; change calendar - (begin - - (format (current-error-port) - "Calendar change~%") - - ;; remove from runtime - ((@ (vcomponent instance methods) remove-event) - global-event-object old-event) - - ;; Actually puring the old event should be safe, - ;; since we first make sure we write the new event to disk. - ;; Currently the whole transaction isn't atomic, so a duplicate - ;; event can still be created. - (set! after-save - ;; remove from disk - (lambda () - (format (current-error-port) - "Unlinking old event from ~a~%" - (prop old-event '-X-HNH-FILENAME)) - ((@ (vcomponent vdir save-delete) remove-event) old-event))) - - (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 ((@ (vcomponent vdir save-delete) save-event) event) - (return (build-response code: 500) - "Saving event to disk failed.")) - - (after-save) - - (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))))) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (vcomponent 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))]) - - (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 '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 ((@ (vcomponent xcal output) 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))))) diff --git a/module/server/server.scm b/module/server/server.scm deleted file mode 100644 index 9c857b6d..00000000 --- a/module/server/server.scm +++ /dev/null @@ -1,34 +0,0 @@ -(define-module (server server) - :use-module (util) - :use-module (web server) - :use-module ((server routes) :select (make-make-routes)) - :use-module (ice-9 threads)) - -;; NOTE The default make-default-socket is broken for IPv6. -;; A patch has been submitted to the mailing list. 2020-03-31 -(module-set! - (resolve-module '(web server http)) - 'make-default-socket - (lambda (family addr port) - (let ((sock (socket family SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock family addr port) - sock))) - -(define handler (make-make-routes)) - -;; (define impl (lookup-server-impl 'http)) -;; (define server (open-server impl open-params)) - - -(define-public (start-server open-params) - (run-server handler 'http open-params 1) - ;; NOTE at first this seems to work, but it quickly deteriorates. - ;; (for i in (iota 16) - ;; (begin-thread - ;; (let lp ((state (list 0))) - ;; (lp (serve-one-client handler impl server state))))) - ;; (pause) - ) - - diff --git a/module/server/test.scm b/module/server/test.scm deleted file mode 100644 index d33be67f..00000000 --- a/module/server/test.scm +++ /dev/null @@ -1,76 +0,0 @@ -(add-to-load-path "..") - -(use-modules (util) - (web server) - - (web response) - (web request) - (web uri) - (ice-9 control) - (ice-9 regex) - (server util) - (server macro) - - (ice-9 iconv) - (srfi srfi-88) - - (sxml simple) - (ice-9 ftw) - (ice-9 rdelim) - ) - -(define (form-page name) - `(div - (p "Hello " ,name) - (form (@ (action "/form") - (method POST)) - (input (@ (type text) - (name name))) - (input (@ (type submit)))))) - -(define (sxml->xml-string sxml) - (with-output-to-string - (lambda () (sxml->xml sxml)))) - -(define routes - (make-routes - - (GET "/" (name) - (return - '((content-type text/plain)) - (format #f "No root page, ~a~%" name))) - - (GET "/form" () - (return - '((content-type text/html)) - (sxml->xml-string (form-page state)))) - - (POST "/form" (name) - (return (build-response - #:code 303 - #:headers `((location . ,(string->uri-reference "/form")))) - "" name)) - - - (GET "/ls" () - (return - '((content-type text/html)) - (sxml->xml-string - `(table - (thead - (th (td "Name") (td "Type") (td "Perm"))) - (tbody - ,@(map (lambda (kv) - (let* (((k stat) kv)) - `(tr (td ,k) - (td ,(stat:type stat)) - (td ,(number->string (stat:perms stat) 8))))) - (cddr (file-system-tree "." (lambda (p _) (string=? p ".")))))))))) - - - (GET "/ls/:file" (file) - (return '((content-type text/plain)) - (call-with-input-file file read-string))))) - -(run-server routes 'http '() "Default Name") - diff --git a/module/server/util.scm b/module/server/util.scm deleted file mode 100644 index 58a11ec3..00000000 --- a/module/server/util.scm +++ /dev/null @@ -1,17 +0,0 @@ -(define-module (server util) - :use-module (util) - :use-module (srfi srfi-1) - :use-module (web uri)) - - -(define*-public (parse-query query-string optional: (encoding "UTF-8")) - (unless (or (not query-string) (string-null? query-string)) - (fold (lambda (str list) - ;; only split on the first equal. - ;; Does HTTP allow multiple equal signs in a data field? - ;; NOTE that this fails if str lacks an equal sign. - (define idx (string-index str #\=)) - (define key (uri-decode (substring str 0 idx) encoding: encoding)) - (define val (uri-decode (substring str (1+ idx)) encoding: encoding)) - (cons* (-> key string->symbol symbol->keyword) val list)) - '() (string-split query-string #\&)))) diff --git a/module/web/http/macro.scm b/module/web/http/macro.scm new file mode 100644 index 00000000..a0113f46 --- /dev/null +++ b/module/web/http/macro.scm @@ -0,0 +1,105 @@ +(define-module (web http make-routes) + :export (make-routes) + :use-module (util) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (web response) + :use-module (web uri)) + + + +(define-public (parse-endpoint-string str) + (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) + (let loop ((str str) + (string "") + (tokens '())) + (let ((m (regexp-exec rx str 0))) + (if (not m) + ;; done + (values (string-append string str) (reverse tokens)) + + (loop (match:suffix m) + (string-append string (match:prefix m) + (aif (match:substring m 3) + (string-append "(" it ")") + "([^/.]+)") + ;; period directly following matched variable. + ;; since many variables break on period, we often + ;; want to match a literal period directly after them. + ;; Ideally all periods outside of pattern should be + ;; matched literally, but that's harder to implement. + (regexp-quote + (aif (match:substring m 4) + "." ""))) + (cons (string->symbol (match:substring m 1)) + tokens))))))) + +(define (generate-case defn) + (let* (((method uri param-list . body) defn) + (regex tokens (parse-endpoint-string uri)) + (diff intersect (lset-diff+intersection eq? param-list tokens))) + `((and (eq? r:method (quote ,method)) + (regexp-exec (make-regexp ,(string-append "^" regex "/?$") regexp/icase) + r:path)) + => (lambda (match-object) + ;; (assert + ;; (= (1- (match:count match-object)) + ;; (length intersect))) + + ;; Those parameters which were present in the template uri + ((lambda ,intersect + ;; Those that only are in the query string + (lambda* (,@(unless (null? diff) `(#:key ,@diff #:allow-other-keys)) + #:rest rest) + ,@body)) + ,@(unless (null? intersect) + (map (lambda (i) + `(match:substring match-object ,i)) + (cdr (iota (1+ (length intersect))))))))))) + +(define-macro (make-routes . routes) + + `(lambda* (request body #:optional state) + ;; (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 ((@ (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 () + ((@ (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))))))))))) + (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/web/query.scm b/module/web/query.scm new file mode 100644 index 00000000..cb96824d --- /dev/null +++ b/module/web/query.scm @@ -0,0 +1,16 @@ +(define-module (web query) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (web uri)) + +(define*-public (parse-query query-string optional: (encoding "UTF-8")) + (unless (or (not query-string) (string-null? query-string)) + (fold (lambda (str list) + ;; only split on the first equal. + ;; Does HTTP allow multiple equal signs in a data field? + ;; NOTE that this fails if str lacks an equal sign. + (define idx (string-index str #\=)) + (define key (uri-decode (substring str 0 idx) encoding: encoding)) + (define val (uri-decode (substring str (1+ idx)) encoding: encoding)) + (cons* (-> key string->symbol symbol->keyword) val list)) + '() (string-split query-string #\&)))) -- cgit v1.2.3