blob: 751ef01e49a54f305f3d68c6248ac9bf978a325f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
(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)
|
