add simple server which takes POST requests

The idea is that it can accept surveys sent to it. Note that in an actual
deployment it should have at least some rate-limiting, since actual validation
of input is impossible if they are encrypted – i.e. this is bascially a pastbin.

It may, however, be possible to require signing answers for survey with access
restrictions, or do a challange/response type thing before allowing submission.

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)