1 files changed, 101 insertions, 0 deletions
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)