summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Readme.org14
-rw-r--r--server/server.scm101
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)