Split module/server into stuff.

5 files changed, 0 insertions, 649 deletions

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 "<!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 ()
-                      (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 <date>.
-   ;; @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 <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 ((@ (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 #\&))))