From 0f8b78c0b7e2aca94a14b36af020d0f7d8301cc5 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 5 Apr 2021 00:50:35 +0200
Subject: 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.
---
 server/Readme.org |  14 ++++++++
 server/server.scm | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 115 insertions(+)
 create mode 100644 server/Readme.org
 create mode 100644 server/server.scm

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)
-- 
cgit v1.2.3