278 lines
15 KiB
Scheme
278 lines
15 KiB
Scheme
(define buffer-size 4000)
|
|
|
|
(define get-replacement
|
|
(lambda (key mode)
|
|
(let ((r (if (string=? mode "encode")
|
|
(assoc key encode-replacements)
|
|
(assoc key decode-replacements))))
|
|
(if r (car (cdr r)) key))))
|
|
|
|
(define scgi-split-by-zero->list
|
|
(lambda (source)
|
|
(let ((result (list))
|
|
(source-size (bytevector-length source)))
|
|
(letrec ((looper
|
|
(lambda (index last-index key value)
|
|
(if (< index source-size)
|
|
(if (and key value)
|
|
(begin
|
|
(if (> (bytevector-length key) 0)
|
|
(set! result
|
|
(append
|
|
result
|
|
(list (cons (utf8->string key)
|
|
(if (= (bytevector-length value) 0)
|
|
""
|
|
(utf8->string value)))))))
|
|
(looper index last-index #f #f))
|
|
(if (= (bytevector-u8-ref source index) 0)
|
|
(let ((slice (bytevector-copy source last-index index)))
|
|
(if (not key)
|
|
(looper (+ index 1) (+ index 1) slice value)
|
|
(looper (+ index 1) (+ index 1) key slice)))
|
|
(looper (+ index 1) last-index key value)))))))
|
|
(looper 0 0 #f #f))
|
|
result)))
|
|
|
|
#;(define scgi-netstring->list
|
|
(lambda (netstring)
|
|
(let ((request (list)))
|
|
(letrec ((get-request
|
|
(lambda (index)
|
|
(if (= (bytevector-u8-ref netstring index) 58)
|
|
(bytevector-copy netstring (+ index 1))
|
|
(get-request (+ index 1))))))
|
|
(if (> (bytevector-length netstring) 0)
|
|
(scgi-split-by-zero->list (get-request 0))
|
|
(list))))))
|
|
|
|
#;(define scgi-get-request-body
|
|
(lambda (request-bytes content-length)
|
|
(letrec ((looper
|
|
(lambda (index)
|
|
(if (and (> (bytevector-length request-bytes) 0)
|
|
(= (bytevector-u8-ref request-bytes index) 0)
|
|
(= (bytevector-u8-ref request-bytes (+ index 1)) 44))
|
|
(bytevector-copy request-bytes (+ index 2))
|
|
(looper (- index 1))))))
|
|
(looper (- (bytevector-length request-bytes) 1)))))
|
|
|
|
#;(define read-all-from-socket
|
|
(lambda (socket result)
|
|
(let ((bytes (socket-recv socket buffer-size)))
|
|
(if (or (eof-object? bytes)
|
|
(< (bytevector-length bytes) buffer-size))
|
|
(bytevector-append result bytes)
|
|
(read-all-from-socket socket (bytevector-append result bytes))))))
|
|
|
|
(define (read-size-from-socket result socket)
|
|
(let ((bytes (socket-recv socket 1)))
|
|
(if (char=? (integer->char (bytevector-u8-ref bytes 0)) #\:)
|
|
(string->number (utf8->string result))
|
|
(read-size-from-socket (bytevector-append result bytes) socket))))
|
|
|
|
(define (read-headers-from-socket socket)
|
|
(socket-recv socket (read-size-from-socket (bytevector) socket)))
|
|
|
|
(define (read-body-from-socket socket content-size)
|
|
(socket-recv socket 1) ; Read away ","
|
|
(socket-recv socket content-size))
|
|
|
|
(define (clean-files)
|
|
(for-each
|
|
(lambda (file)
|
|
(let ((path (cdr file)))
|
|
(when (file-exists? path)
|
|
(delete-file path))))
|
|
files))
|
|
|
|
(define request (list))
|
|
(define files (list))
|
|
|
|
(define string-split
|
|
(lambda (str mark)
|
|
(let* ((str-l (string->list str))
|
|
(res (list))
|
|
(last-index 0)
|
|
(index 0)
|
|
(splitter (lambda (c)
|
|
(cond ((char=? c mark)
|
|
(begin
|
|
(set! res (append res (list (string-copy str last-index index))))
|
|
(set! last-index (+ index 1))))
|
|
((equal? (length str-l) (+ index 1))
|
|
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
|
(set! index (+ index 1)))))
|
|
(for-each splitter str-l)
|
|
res)))
|
|
|
|
(define split-http-parameters
|
|
(lambda (body)
|
|
(cond ((or (not (string? body))
|
|
(string=? "" body))
|
|
(list))
|
|
(else (let ((bodylist (string->list body)))
|
|
(map (lambda (p)
|
|
(cons (list-ref p 0)
|
|
(if (> (length p) 1)
|
|
(list-ref p 1)
|
|
"")))
|
|
(map (lambda (x) (string-split x #\=))
|
|
(string-split (list->string bodylist)
|
|
#\&))))))))
|
|
|
|
(define string-filter
|
|
(lambda (str filter)
|
|
(let ((result (list)))
|
|
(string-for-each
|
|
(lambda (c)
|
|
(if (filter c)
|
|
(set! result (append result (list c)))))
|
|
str)
|
|
(list->string result))))
|
|
|
|
(define read-binary-port-until
|
|
(lambda (port result until)
|
|
(let ((byte (read-u8 port)))
|
|
(if (or (eof-object? byte)
|
|
(= byte until))
|
|
result
|
|
(read-binary-port-until port (bytevector-append result
|
|
(bytevector byte))
|
|
until)))))
|
|
|
|
(define read-bytevector-line
|
|
(lambda (port)
|
|
(let* ((result (utf8->string (read-binary-port-until port
|
|
(bytevector)
|
|
(char->integer #\newline))))
|
|
(result-length (string-length result))
|
|
(ends-in-return? (and (> result-length 0)
|
|
(char=? (string-ref result (- result-length 1))
|
|
#\return))))
|
|
(cond ((= result-length 0) "")
|
|
(ends-in-return? (string-copy result 0 (- result-length 1)))
|
|
(else result)))))
|
|
|
|
(define breaker (char->integer #\-))
|
|
|
|
(define scgi-internal-handle
|
|
(lambda (client-socket thunk)
|
|
(let* ((headers (scgi-split-by-zero->list (read-headers-from-socket client-socket)))
|
|
(request-method (if (not (null? headers)) (cdr (assoc "REQUEST_METHOD" headers)) ""))
|
|
(content-length (if (not (null? headers)) (string->number (cdr (assoc "CONTENT_LENGTH" headers))) 0))
|
|
(content-type-pair (if (assoc "CONTENT_TYPE" headers)
|
|
(assoc "CONTENT_TYPE" headers)
|
|
(cons "Content-Type" "text/html")))
|
|
(parameters (list))
|
|
(content-type-data (string-split (cdr content-type-pair) #\;))
|
|
(content-type (list-ref content-type-data 0))
|
|
(body (if (> content-length 0)
|
|
(if (string=? content-type "multipart/form-data")
|
|
(bytevector)
|
|
(read-body-from-socket client-socket content-length))
|
|
(bytevector))))
|
|
(cond ((and content-type-pair (string=? content-type "multipart/form-data"))
|
|
(letrec* ((boundary (string->utf8 (string-append (list-ref (string-split
|
|
(list-ref content-type-data 1) #\=) 1))))
|
|
(boundary-length (bytevector-length boundary))
|
|
(content (read-body-from-socket client-socket content-length))
|
|
(content-mark 0)
|
|
(looper (lambda (index)
|
|
(cond ((< index (- content-length 4))
|
|
(if (and (= breaker (bytevector-u8-ref content index))
|
|
(= breaker (bytevector-u8-ref content (+ index 1)))
|
|
(equal? boundary (bytevector-copy content (+ index 2) (+ index 2 boundary-length))))
|
|
(let* ((part (bytevector-copy content content-mark index))
|
|
(part-length (bytevector-length part))
|
|
(part-port (open-input-bytevector part))
|
|
(part-headers-length 0)
|
|
(part-headers (letrec ((loop (lambda (line result)
|
|
(if (or (eof-object? line) (string=? line ""))
|
|
(map (lambda (p) (string-split p #\:)) result)
|
|
(begin
|
|
(set! part-headers-length (+ part-headers-length
|
|
(string-length line)
|
|
2))
|
|
(loop (read-bytevector-line part-port)
|
|
(append result (list line))))))))
|
|
(loop (read-bytevector-line part-port) (list)))))
|
|
(if (and (not (null? part-headers))
|
|
(assoc "Content-Disposition" part-headers))
|
|
(let* ((content-disposition
|
|
(map
|
|
(lambda (str)
|
|
(let ((split (string-split str #\=)))
|
|
(cons (string-filter (list-ref split 0) (lambda (c) (not (char=? c #\space))))
|
|
(if (= (length split) 2)
|
|
(string-filter (list-ref split 1) (lambda (c) (not (char=? c #\"))))
|
|
""))))
|
|
(string-split (car (cdr (assoc "Content-Disposition" part-headers))) #\;)))
|
|
(filename (assoc "filename" content-disposition)))
|
|
(if (not filename)
|
|
(set! parameters
|
|
(append parameters
|
|
(list
|
|
(cons (cdr (assoc "name" content-disposition))
|
|
(utf8->string (bytevector-copy content
|
|
(+ (+ content-mark part-headers-length) 2)
|
|
(- index 2)))))))
|
|
(let* ((tmp-file-path (make-temp-filename (cdr filename)))
|
|
(tmp-file-port (begin (when (file-exists? tmp-file-path)
|
|
(delete-file tmp-file-path))
|
|
(open-binary-output-file tmp-file-path))))
|
|
(write-bytevector (bytevector-copy content
|
|
(+ (+ content-mark part-headers-length) 2)
|
|
(- index 2))
|
|
tmp-file-port)
|
|
(close-port tmp-file-port)
|
|
(set! files (append files (list
|
|
(cons (cdr (assoc "name" content-disposition))
|
|
tmp-file-path))))))
|
|
(set! content-mark index)))
|
|
(looper (+ index boundary-length)))
|
|
(looper (+ index 1))))))))
|
|
(looper 0)))
|
|
((string=? request-method "POST")
|
|
(set! parameters (split-http-parameters (url-decode (utf8->string body)))))
|
|
(else (if (not (null? headers))
|
|
(split-http-parameters (cdr (assoc "QUERY_STRING" headers)))
|
|
(list))))
|
|
(set! request (list (cons 'headers headers)
|
|
(cons 'parameters parameters)
|
|
(cons 'files files)
|
|
(cons 'body (url-decode (utf8->string body)))))
|
|
(with-exception-handler
|
|
(lambda (ex)
|
|
(socket-send client-socket (string->utf8 "#f")))
|
|
(lambda ()
|
|
(let ((response (parameterize
|
|
((current-output-port (open-output-string)))
|
|
(apply thunk
|
|
(list request
|
|
headers
|
|
parameters
|
|
'() ;; TODO Cookies
|
|
(url-decode (utf8->string body))
|
|
files))
|
|
(set! request (list))
|
|
(set! files (list))
|
|
(get-output-string (current-output-port)))))
|
|
(socket-send client-socket
|
|
(string->utf8 (if (string? response)
|
|
response
|
|
""))))))
|
|
(socket-close client-socket))))
|
|
|
|
(define scgi-listen
|
|
(lambda (socket thunk)
|
|
(scgi-internal-handle (socket-accept socket) thunk)
|
|
(clean-files)
|
|
(scgi-listen socket thunk)))
|
|
|
|
(define (handle-request options thunk)
|
|
(let ((port (assoc 'port options)))
|
|
(when (not port)
|
|
(error "handle-request (scgi) requires port to be passed in options, example: '((port . \"3000\"))"))
|
|
(scgi-listen (make-server-socket (cdr port) *af-inet* *sock-stream* *ipproto-ip*) thunk)))
|