summaryrefslogtreecommitdiff
path: root/server/server.scm
diff options
context:
space:
mode:
authorstuebinm2021-04-27 00:34:17 +0200
committerstuebinm2021-04-27 00:34:17 +0200
commit69eb6fe0a6ac34cf412bd6ba23dd11c5b7fbd417 (patch)
treeb81f466e459ee6384b4c13c816094013cd0df7f9 /server/server.scm
parent91efe78471f080eb58ffdde2125c59cd76d1f62c (diff)
server: replace guile with rust (init)
this is just a quick barebones server, which doesn't really do yet what it is supposed to or what the guile version did.
Diffstat (limited to 'server/server.scm')
-rw-r--r--server/server.scm102
1 files changed, 0 insertions, 102 deletions
diff --git a/server/server.scm b/server/server.scm
deleted file mode 100644
index 751ef01..0000000
--- a/server/server.scm
+++ /dev/null
@@ -1,102 +0,0 @@
-(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)
- (ice-9 binary-ports))
-
-
-(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")
- (put-bytevector port body))))
- ((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)