diff options
Diffstat (limited to '')
| -rw-r--r-- | server/server.scm | 102 |
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) |