diff options
| -rw-r--r-- | server/Readme.org | 14 | ||||
| -rw-r--r-- | server/server.scm | 101 |
2 files changed, 115 insertions, 0 deletions
diff --git a/server/Readme.org b/server/Readme.org new file mode 100644 index 0000000..1242159 --- /dev/null +++ b/server/Readme.org @@ -0,0 +1,14 @@ +#+TITLE: Simple Server that accepts survey answers + +Run with: +#+BEGIN_SRC +guile server.scm +#+END_SRC + +Will listen to localhost:8080, and accept files sent via POST with +mimetypes of either ~text/plain~ (which will be appended to a single +file in the working directory) or ~text/age~ (which will be kept as a +single file). + +Expects a custom header ~X-Survey~ in these requests to know which survey +the answer belongs to. diff --git a/server/server.scm b/server/server.scm new file mode 100644 index 0000000..5159314 --- /dev/null +++ b/server/server.scm @@ -0,0 +1,101 @@ +(use-modules (web server) + (web request) + (web response) + (web http) + (web uri)) + +(use-modules (ice-9 format) + (ice-9 textual-ports) + (ice-9 iconv) + (ice-9 match)) + + +(define (get-path request) + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (get-last list) + (list-ref list (- (length list) 1))) + +;; This was intended to also server the files. +;; However, it turns out that guile will attempt to "sanitise" anything +;; sent as response to anything, which includes attaching charsets to +;; all mimetypes it sees. Since the wasm specifications are also weird, +;; this results in the app not running at all since web assembly can't +;; be instantiated correctly on the client's side. +;; +;; So instead, just use another web server for serving files. +(define (fetch-file path) + (let ((ext (car (cdr (string-split (car (last-pair path)) (string->char-set ".")))))) + (let ((mimetype + (cond + ((equal? ext "html") 'text/html) + ((equal? ext "css") 'text/css) + ((equal? ext "js") 'text/javascript) + ((equal? ext "wasm") 'application/wasm) + (else "undefined")))) + (format #t "mimetype for .~a is ~a\n" ext mimetype) + (format #t "~a" (values `((content-type ,mimetype)) "test")) + (values (build-response + #:code 200 + #:headers `((content-type . (,mimetype (charset . "iso-8859-1")))) + #:validate-headers? #f) + (call-with-input-file (format #f "~a" (get-last path)) + (lambda (port) (get-string-all port))))))) + +(define (call-with-append-file filename proc) + (let ((port (open-file filename "a"))) + (proc port) + (newline port) + (close port))) + +;; extracts the (first) content type given in a set of headers +;; TODO: saveguards against multiple given content-types? +(define (get-header type request) + (cdr (car (filter + (lambda (header) + (equal? (car header) type)) + (request-headers request))))) + +;; accepts a POST request (assuming it contains a survey +;; response which should be saved somewhere) +(define (do-post request body) + (let ((survey (get-header 'x-survey request))) + (format #t "answer to survey ~a " survey) + ;; debug option to display ingoing answers before saving + ;(format #t "~a\n" (bytevector->string body "utf8")) + ;; content-types are wrapped into an extra () by guile + (case (car (get-header 'content-type request)) + ((text/age) (call-with-output-file + (string-append + survey "-answer" + ; save encrypted answers in their own files, using a hash + ; of the answer as name postfix (since age doesn't + ; produce the same ciphertext for the same input twice, + ; this ensures absence of collissions /and/ not counting + ; answers mistakenly sent twice double!) + (number->string (hash body 10000000000)) ".age") + (lambda (port) + (display "(encrypted)\n") + (display (bytevector->string body "ascii") port)))) + ((text/plain) (call-with-append-file + (string-append survey ".survey") + (lambda (port) + (display "(plaintext)\n") + (display (bytevector->string body "utf8") port))))) + (values '((content-type . (text/plain))) + "Hey, thanks for your answers!\n"))) + +;; main server function; delivers files on GET, and interprets +;; everything else as attempts at submissions. +(define (test-handler request body) + (let ((path (get-path request))) + (format #t "got request: ~a: ~:a\n" + (request-method request) + path) + (if (equal? (format #f "~a" (request-method request)) "POST") + (do-post request body) + (values '() "nothing here")))) + + + +(run-server test-handler) |