From 8fefdc707257b2ed1a2fde2c267e6f17d1babd78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 22 May 2019 22:28:29 +0200 Subject: Large work on server software. --- module/server.scm | 30 +++++++++++++++++-- module/server/macro.scm | 73 ++++++++++++++++++++++++++++++++++++++++++++ module/server/test.scm | 80 +++++++++++++++++++++++++++++++++++++++++++++++++ module/server/util.scm | 10 +++++++ tests/server.scm | 6 ++++ 5 files changed, 196 insertions(+), 3 deletions(-) create mode 100644 module/server/macro.scm create mode 100644 module/server/test.scm create mode 100644 module/server/util.scm create mode 100644 tests/server.scm diff --git a/module/server.scm b/module/server.scm index 063f6fc7..812f2453 100644 --- a/module/server.scm +++ b/module/server.scm @@ -3,8 +3,10 @@ (use-modules* (web (server request response uri)) (output (html)) - (ice-9 (match control rdelim curried-definitions)) - (srfi (srfi-1 srfi-19))) + (server (util macro)) + (ice-9 (match control rdelim curried-definitions + regex #| regex here due to bad macros |# )) + (srfi (srfi-1 srfi-19 srfi-88))) (define month-names '(jan feb mar apr may jun jul aug sep oct nov dec)) @@ -26,6 +28,7 @@ read-string))) ;;; TODO "/static/*" +#; (define (make-handler calendars events) (lambda (request request-body) (format (current-error-port) "[~a] ~a~%" @@ -51,5 +54,26 @@ (ret (build-response #:code 404) "404 Not Fonud")))))))))) +(define* (date key: (year 0) (month 0) (day 0) (hour 0) (minute 0) (second 0) (nsecs 0) (zone 0)) + (make-date nsecs second minute hour day month year zone)) + +(define (make-make-routes calendar events) + (make-routes + + (GET "/" (m) + (let* ((start (if m + (date year: 2019 day: 1 month: (string->number m)) + (current-date))) + (end (set (date-month start) = (+ 1)))) + (return '((content-type text/html)) + (with-output-to-string + (lambda () (html-generate calendar events start end)))))) + + (GET "/static/:filename/" (filename) + ((serve-file return) filename)) + + )) + + (define-public (server-main c e args) - (run-server (make-handler c e))) + (run-server (make-make-routes c e))) diff --git a/module/server/macro.scm b/module/server/macro.scm new file mode 100644 index 00000000..951e009d --- /dev/null +++ b/module/server/macro.scm @@ -0,0 +1,73 @@ +(define-module (server macro) + :export (make-routes) + :use-module (util) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + ) + +(use-modules* (web (response uri))) + +(define (not-null? obj) + (if (null? obj) #f obj)) + +(define (match-count pattern str) + (fold-matches pattern str 0 + (lambda (_ count) + (1+ count)))) + + + +(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) + (values (string-append string str) (reverse tokens)) + (loop (match:suffix m) + (string-append string (match:prefix m) "([^/]+)") + (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))) + ((lambda ,intersect + (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) + (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 (uri-host r:uri)) + (r:port (uri-port r:uri)) + (r:path (uri-path r:uri)) + (r:query (uri-query r:uri)) + (r:fragment (uri-fragment r:uri))) + (call/ec (lambda (return) + (apply + (cond ,@(map generate-case routes) + (else (lambda* _ (return (build-response #:code 404) + "404 Not Fonud")))) + (parse-query r:query)))))))) diff --git a/module/server/test.scm b/module/server/test.scm new file mode 100644 index 00000000..33951695 --- /dev/null +++ b/module/server/test.scm @@ -0,0 +1,80 @@ +(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) + + (sxml simple) + (ice-9 ftw)) + +(define *name* "") + +(define (form-page) + `(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)))) + + (POST "/form" () + (when (memv 'application/x-www-form-urlencoded (assoc-ref r:headers 'content-type)) + (apply (lambda* (#:key name #:allow-other-keys) + (format #t "*name* := [~a] Received [~a]~%" *name* name) + (set! *name* name)) + (parse-query (uri-decode (bytevector->string body "UTF-8"))))) + (return (build-response + #:code 303 + #:headers `((location . ,(string->uri-reference "/form")))) + "")) + + + (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 (string-append "./" file) + (@ (ice-9 rdelim) read-string)))))) + +(run-server routes) diff --git a/module/server/util.scm b/module/server/util.scm new file mode 100644 index 00000000..b9bc6099 --- /dev/null +++ b/module/server/util.scm @@ -0,0 +1,10 @@ +(define-module (server util) + :use-module (util) + :use-module (srfi srfi-1)) + +(define-public (parse-query query) + (when query + (fold (lambda (str list) + (let* (((k v) (string-split str #\=))) + (cons* (-> k string->symbol symbol->keyword) v list))) + '() (string-split query #\&)))) diff --git a/tests/server.scm b/tests/server.scm new file mode 100644 index 00000000..0821d85e --- /dev/null +++ b/tests/server.scm @@ -0,0 +1,6 @@ +(use-modules (server macro)) + +(parse-endpoint-string "/static/:dir/:file") +;; => "/static/([^/]+)/([^/]+)" +;; => (dir file) + -- cgit v1.2.3