summaryrefslogtreecommitdiff
path: root/server/server.scm
diff options
context:
space:
mode:
authorstuebinm2021-04-05 00:50:35 +0200
committerstuebinm2021-04-05 00:53:23 +0200
commit0f8b78c0b7e2aca94a14b36af020d0f7d8301cc5 (patch)
treeeebc14b5dbe7e5af541ffaa3efa4fd397c5f671d /server/server.scm
parentef1624f645b53cf60c89b2caabc3087883ad7dbd (diff)
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.
Diffstat (limited to 'server/server.scm')
-rw-r--r--server/server.scm101
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)