317 lines
15 KiB
Scheme
317 lines
15 KiB
Scheme
(define stdin (open-binary-input-file "/dev/fd/0"))
|
|
(define buffer-size 4000)
|
|
(define temporary-directory (if (get-environment-variable "SCHEME_CGI_TMP_PATH")
|
|
(get-environment-variable "SCHEME_CGI_TMP_PATH")
|
|
"/tmp"))
|
|
(define file-move-buffer-size 4000)
|
|
(define encode-replacements
|
|
(list (list " " "%20")
|
|
(list " " "+")
|
|
(list "!" "%21")
|
|
(list "#" "%23")
|
|
(list "$" "%24")
|
|
(list "%" "%25")
|
|
(list "&" "%26")
|
|
(list "'" "%27")
|
|
(list "(" "%28")
|
|
(list ")" "%29")
|
|
(list "*" "%2A")
|
|
(list "+" "%2B")
|
|
(list "," "%2C")
|
|
(list "/" "%2F")
|
|
(list ":" "%3A")
|
|
(list ";" "%3B")
|
|
(list "=" "%3D")
|
|
(list "?" "%3F")
|
|
(list "@" "%40")
|
|
(list "[" "%5B")
|
|
(list "]" "%5D")
|
|
(list "<" "%3C")
|
|
(list ">" "%3E")
|
|
(list "\\" "%5C")
|
|
(list "\"" "%22")
|
|
(list "\n" "%0A")
|
|
(list "\r" "%0D")))
|
|
(define decode-replacements (map reverse encode-replacements))
|
|
|
|
(define make-temp-filename
|
|
(lambda (filename)
|
|
(letrec* ((dev-random (open-binary-input-file "/dev/random"))
|
|
(min-byte (char->integer #\a))
|
|
(max-byte (char->integer #\z))
|
|
(max-length 10)
|
|
(looper (lambda (result count)
|
|
(if (>= count max-length)
|
|
result
|
|
(let ((byte (read-u8 dev-random)))
|
|
(if (and (> byte min-byte) (< byte max-byte))
|
|
(looper (bytevector-append result
|
|
(bytevector byte))
|
|
(+ count 1))
|
|
(looper result count))))))
|
|
(result (string-append (utf8->string (looper (bytevector) 0))
|
|
"_"
|
|
(utf8->string (looper (bytevector) 0))
|
|
"_"
|
|
filename)))
|
|
(close-port dev-random)
|
|
result)))
|
|
|
|
#;(define headers->string
|
|
(lambda (headers)
|
|
(apply string-append (map
|
|
(lambda (key-value)
|
|
(string-append (car key-value) ": " (cdr key-value) "\r\n"))
|
|
headers))))
|
|
|
|
(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 endecode
|
|
(lambda (mode s)
|
|
(if (not s)
|
|
""
|
|
(letrec ((s-length (string-length s))
|
|
(looper
|
|
(lambda (i result)
|
|
(if (< i s-length)
|
|
(let ((key-length (if (and (string=? mode "decode")
|
|
(string=? (string-copy s i (+ i 1)) "%")
|
|
(> s-length (+ i 2)))
|
|
3
|
|
1)))
|
|
(looper (+ i key-length)
|
|
(string-append result
|
|
(get-replacement
|
|
(string-copy s i (+ i key-length))
|
|
mode))))
|
|
result))))
|
|
(looper 0 "")))))
|
|
|
|
(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 (string->symbol (list-ref p 0))
|
|
(if (> (length p) 1)
|
|
(list-ref p 1)
|
|
"")))
|
|
(map (lambda (x) (string-split x #\=))
|
|
(string-split (list->string bodylist)
|
|
#\&))))))))
|
|
|
|
|
|
(define read-until-eof
|
|
(lambda (port result)
|
|
(let ((c (read-bytevector buffer-size port)))
|
|
(if (eof-object? c)
|
|
(utf8->string result)
|
|
(read-until-eof port (bytevector-append result c))))))
|
|
|
|
(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 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 headers (map (lambda (p)
|
|
(cons (string->symbol (car p))
|
|
(cdr p)))
|
|
(get-environment-variables)))
|
|
(define content-type-pair (if (assoc 'CONTENT_TYPE headers)
|
|
(assoc 'CONTENT_TYPE headers)
|
|
(cons "Content-Type" "text/html")))
|
|
(define content-type-data (string-split (cdr content-type-pair) #\;))
|
|
(define content-type (list-ref content-type-data 0))
|
|
(define request-method (if (assoc 'REQUEST_METHOD headers)
|
|
(cdr (assoc 'REQUEST_METHOD headers))
|
|
"GET"))
|
|
|
|
(define query-string (if (assoc 'QUERY_STRING headers)
|
|
(cdr (assoc 'QUERY_STRING headers))
|
|
""))
|
|
(define parameters (list))
|
|
(define cookies (let ((cookie-string (get-environment-variable "HTTP_COOKIE")))
|
|
(if cookie-string
|
|
(split-http-parameters cookie-string)
|
|
(list))))
|
|
(define body "")
|
|
(define files (list))
|
|
|
|
(define breaker (char->integer #\-))
|
|
|
|
|
|
(define request
|
|
(list (cons 'headers headers)
|
|
(cons 'parameters parameters)
|
|
(cons 'cookies cookies)
|
|
(cons 'body body)
|
|
(cons 'files files)))
|
|
|
|
(define (get from key)
|
|
(let ((value (assoc (if (string? key)
|
|
(string->symbol (endecode "encode" key))
|
|
key)
|
|
from)))
|
|
(if value (cdr value) #f)))
|
|
(define (get-file file)
|
|
(let ((value (assoc (endecode "encode" (if (symbol? file)
|
|
(symbol->string file)
|
|
file))
|
|
files)))
|
|
(if value (cdr value) #f)))
|
|
(define (move-file from to)
|
|
(letrec* ((input (open-binary-input-file from))
|
|
(output (open-binary-output-file to))
|
|
(looper (lambda (bytes)
|
|
(when (not (eof-object? bytes))
|
|
(write-bytevector bytes output)
|
|
(looper (read-bytevector file-move-buffer-size input))))))
|
|
(looper (read-bytevector file-move-buffer-size input))
|
|
(close-port input)
|
|
(close-port output)))
|
|
|
|
(define (cgi) request)
|
|
|
|
(define cgi-exit
|
|
(lambda args
|
|
(for-each (lambda (file)
|
|
(let ((path (cdr file)))
|
|
(when (file-exists? path)
|
|
(delete-file path))))
|
|
files)
|
|
(if (null? args)
|
|
(exit 0)
|
|
(exit (car args)))))
|
|
|
|
(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 (letrec ((looper (lambda (bytes result)
|
|
(if (eof-object? bytes)
|
|
result
|
|
(looper (read-bytevector buffer-size stdin)
|
|
(bytevector-append result bytes))))))
|
|
(looper (read-bytevector buffer-size stdin)
|
|
(bytevector))))
|
|
(header-content-length (string->number (cdr (assoc 'CONTENT_LENGTH headers))))
|
|
(content-length (bytevector-length content))
|
|
(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 (string-append temporary-directory
|
|
"/"
|
|
(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)))
|
|
(else (let ((raw-body (if (string=? request-method "POST")
|
|
(read-until-eof stdin (bytevector))
|
|
"")))
|
|
(set! parameters (split-http-parameters (if (string=? request-method "POST")
|
|
raw-body
|
|
query-string)))
|
|
(when (string=? request-method "POST")
|
|
(set! body raw-body)))))
|