Harden HTTPS server request handling
ober
c595579d44499ed7baff9b8aad039924b4fc322c
--- a/lib/jerboa-https.sls +++ b/lib/jerboa-https.sls @@ -12,8 +12,9 @@ printf fprintf format path-extension path-absolute? with-input-from-string with-output-to-string iota \x31;+ \x31;- partition make-date make-time meta atom?) - (except (jerboa prelude) string-join string-trim - string-contains string-index string-prefix?) + (except (jerboa prelude) string-join string-trim string-contains + string-index string-prefix? tcp-write-string tcp-write + tcp-read tcp-close tcp-accept tcp-listen tcp-connect) (jerboa-ssl)) (def (string-prefix? prefix str) (let ([plen (string-length prefix)] @@ -91,6 +92,16 @@ (loop (cdr bvs) (+ offset (bytevector-length bv))))))))) + (define request-body-write-chunk-size 8388608) + (define request-io-timeout-seconds 300) + (def (ssl-write-bytevector-chunked conn bv) + (let ([len (bytevector-length bv)]) + (let loop ([offset 0]) + (when (< offset len) + (let ([end (min len + (+ offset request-body-write-chunk-size))]) + (ssl-write conn (subbytevector bv offset end)) + (loop end)))))) (def (find-crlfcrlf bv len start) (let loop ([i start]) (if (> (+ i 3) len) @@ -580,6 +591,11 @@ [pooled-conn (pool-get host port)] [conn (or pooled-conn (ssl-connect host port))] [using-pooled? (and pooled-conn #t)] + [_timeout (unless using-pooled? + (ssl-set-timeout + conn + request-io-timeout-seconds + request-io-timeout-seconds))] [request-str (build-request method full-path host flat-headers body-bv #t)]) (guard (e @@ -593,7 +609,7 @@ (guard (e2 [#t (void)]) (ssl-close conn)) (raise e)))]) (ssl-write-string conn request-str) - (when body-bv (ssl-write conn body-bv)) + (when body-bv (ssl-write-bytevector-chunked conn body-bv)) (let-values ([(status resp-headers body keep-alive?) (read-response conn)]) (if keep-alive? @@ -603,12 +619,16 @@ (def (do-request-fresh method host port full-path flat-headers body-bv) (let* ([conn (ssl-connect host port)] + [_timeout (ssl-set-timeout + conn + request-io-timeout-seconds + request-io-timeout-seconds)] [request-str (build-request method full-path host flat-headers body-bv #t)]) (guard (e [#t (guard (e2 [#t (void)]) (ssl-close conn)) (raise e)]) (ssl-write-string conn request-str) - (when body-bv (ssl-write conn body-bv)) + (when body-bv (ssl-write-bytevector-chunked conn body-bv)) (let-values ([(status resp-headers body keep-alive?) (read-response conn)]) (if keep-alive? --- a/lib/jerboa-https/httpd.sls +++ b/lib/jerboa-https/httpd.sls @@ -17,11 +17,9 @@ printf fprintf format path-extension path-absolute? with-input-from-string with-output-to-string iota \x31;+ \x31;- partition make-date make-time meta atom?) - (except - (jerboa prelude) - string-trim - string-prefix? - string-index) + (except (jerboa prelude) string-trim string-prefix? string-index + tcp-write-string tcp-write tcp-read tcp-close tcp-accept + tcp-listen tcp-connect) (jerboa-ssl)) (def *config* (vector 4 8192 32768 60 120 1048576 128)) (def (cfg-ref i) (vector-ref *config* i)) @@ -48,6 +46,16 @@ [slen (string-length str)]) (and (>= slen plen) (string=? prefix (substring str 0 plen))))) + (def (string-ci-contains? haystack needle) + (let* ([h (string-downcase haystack)] + [n (string-downcase needle)] + [nlen (string-length n)] + [hlen (string-length h)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? n (substring h i (+ i nlen))) #t] + [else (loop (+ i 1))])))) (def (string-trim-left str) (let ([len (string-length str)]) (let loop ([i 0]) @@ -245,31 +253,42 @@ (vector-ref r 4))]) (and pair (cdr pair)))) (def (parse-request-line line) - (let* ([sp1 (string-index line #\space)] - [method (substring line 0 sp1)] - [rest (substring line (+ sp1 1) (string-length line))] - [sp2 (string-index rest #\space)] - [target (substring rest 0 sp2)] - [version (substring rest (+ sp2 1) (string-length rest))] - [qmark (string-index target #\?)] - [path (if qmark (substring target 0 qmark) target)] - [query (if qmark - (substring - target - (+ qmark 1) - (string-length target)) - #f)]) - (values method path query version))) + (let ([sp1 (string-index line #\space)]) + (if (not sp1) + (values #f #f #f #f) + (let* ([method (substring line 0 sp1)] + [rest (substring line (+ sp1 1) (string-length line))] + [sp2 (string-index rest #\space)]) + (if (not sp2) + (values #f #f #f #f) + (let* ([target (substring rest 0 sp2)] + [version (substring + rest + (+ sp2 1) + (string-length rest))] + [qmark (string-index target #\?)] + [path (if qmark + (substring target 0 qmark) + target)] + [query (if qmark + (substring + target + (+ qmark 1) + (string-length target)) + #f)]) + (values method path query version))))))) (def (read-request reader client-addr) (let ([request-line (reader-read-line reader)]) (if (not request-line) #f (let-values ([(method path query version) (parse-request-line request-line)]) - (let ([headers (read-headers reader)]) - (let ([body (read-request-body reader headers)]) - (make-http-request method path query version headers - body client-addr))))))) + (if (not method) + #f + (let ([headers (read-headers reader)]) + (let ([body (read-request-body reader headers)]) + (make-http-request method path query version headers + body client-addr)))))))) (def (read-headers reader) (let loop ([acc '()]) (let ([line (reader-read-line reader)]) @@ -303,17 +322,24 @@ (read-chunked-request-body reader)] [else #f]))) (def (read-chunked-request-body reader) - (let loop ([chunks '()]) + (let loop ([chunks '()] [total 0]) (let* ([size-line (reader-read-line reader)] - [chunk-size (string->number (string-trim size-line) 16)]) + [chunk-size (and size-line + (string->number + (string-trim size-line) + 16))]) (cond [(or (not chunk-size) (= chunk-size 0)) (reader-read-line reader) (bytevector-concat-list (reverse chunks))] + [(or (< chunk-size 0) (> (+ total chunk-size) (cfg-ref 5))) + #f] [else (let ([chunk (reader-read-bytes reader chunk-size)]) (reader-read-line reader) - (loop (cons chunk chunks)))])))) + (if chunk + (loop (cons chunk chunks) (+ total chunk-size)) + #f))])))) (def (string-trim str) (let* ([len (string-length str)] [start (let loop ([i 0]) @@ -343,6 +369,18 @@ (loop (cdr bvs) (+ offset (bytevector-length bv))))))))) + (def (safe-static-relative-path rel) + (if (or (string-prefix? "/" rel) + (string-ci-contains? rel "%2e") + (string-ci-contains? rel "%2f") + (string-ci-contains? rel "%5c")) + #f + (let loop ([parts (string-split rel #\/)]) + (cond + [(null? parts) rel] + [(or (string=? (car parts) "..") (string=? (car parts) ".")) + #f] + [else (loop (cdr parts))])))) (def (status-text code) (case code [(200) "OK"] @@ -594,9 +632,10 @@ (let loop () (unless (unbox stop-box) (let-values ([(client-fd client-addr) - (tcp-accept listen-fd)]) + (guard (e [#t (values #f #f)]) + (tcp-accept listen-fd))]) (cond - [(not client-fd) (loop)] + [(not client-fd) (unless (unbox stop-box) (loop))] [ssl-ctx (guard (e [#t (tcp-close client-fd)]) (tcp-set-timeout client-fd 60 120) @@ -633,12 +672,13 @@ path (string-length url-prefix) (string-length path))] - [safe-rel (if (or (string-prefix? "/" rel) - (string-prefix? ".." rel)) - "" - rel)] - [file-path (string-append directory "/" safe-rel)]) - (http-respond-file writer req file-path))))) + [safe-rel (safe-static-relative-path rel)]) + (if safe-rel + (http-respond-file + writer + req + (string-append directory "/" safe-rel)) + (http-respond-error writer 403)))))) (def (httpd-start port . args) (ssl-init!) (let ([router (if (and (pair? args) @@ -705,7 +745,7 @@ (set-box! stop-box #t) (tcp-close listen-fd) (for-each - (lambda (_) (wq-enqueue! wq (cons *stop-sentinel* ""))) + (lambda (_) (wq-enqueue! wq *stop-sentinel*)) workers) (when ssl-ctx (ssl-server-ctx-free ssl-ctx)) (display "chez-httpd: stopped\n")))) --- a/src/jerboa-https.ss +++ b/src/jerboa-https.ss @@ -14,7 +14,13 @@ request-headers request-header request-close ;; Utilities parse-url flatten-request-headers build-query-string url-encode) - (import (jerboa prelude) (jerboa-ssl)) + (import + (except (jerboa prelude) + string-join string-trim string-contains + string-index string-prefix? + tcp-write-string tcp-write tcp-read + tcp-close tcp-accept tcp-listen tcp-connect) + (jerboa-ssl)) ;; ================================================================ ;; String utilities @@ -105,6 +111,17 @@ (bytevector-copy! bv 0 result offset (bytevector-length bv)) (loop (cdr bvs) (+ offset (bytevector-length bv))))))))) + (define request-body-write-chunk-size 8388608) + (define request-io-timeout-seconds 300) + + (def (ssl-write-bytevector-chunked conn bv) + (let ([len (bytevector-length bv)]) + (let loop ([offset 0]) + (when (< offset len) + (let ([end (min len (+ offset request-body-write-chunk-size))]) + (ssl-write conn (subbytevector bv offset end)) + (loop end)))))) + (def (find-crlfcrlf bv len start) (let loop ([i start]) (if (> (+ i 3) len) @@ -654,6 +671,12 @@ [pooled-conn (pool-get host port)] [conn (or pooled-conn (ssl-connect host port))] [using-pooled? (and pooled-conn #t)] + [_timeout + (unless using-pooled? + (ssl-set-timeout + conn + request-io-timeout-seconds + request-io-timeout-seconds))] [request-str (build-request method full-path host flat-headers body-bv #t)]) (guard (e [#t ;; If a pooled connection failed (stale), retry with fresh @@ -665,7 +688,7 @@ (guard (e2 [#t (void)]) (ssl-close conn)) (raise e)))]) (ssl-write-string conn request-str) - (when body-bv (ssl-write conn body-bv)) + (when body-bv (ssl-write-bytevector-chunked conn body-bv)) (let-values ([(status resp-headers body keep-alive?) (read-response conn)]) (if keep-alive? (pool-put host port conn) @@ -675,12 +698,17 @@ (def (do-request-fresh method host port full-path flat-headers body-bv) ;; Retry with a fresh connection (no keep-alive reuse). (let* ([conn (ssl-connect host port)] + [_timeout + (ssl-set-timeout + conn + request-io-timeout-seconds + request-io-timeout-seconds)] [request-str (build-request method full-path host flat-headers body-bv #t)]) (guard (e [#t (guard (e2 [#t (void)]) (ssl-close conn)) (raise e)]) (ssl-write-string conn request-str) - (when body-bv (ssl-write conn body-bv)) + (when body-bv (ssl-write-bytevector-chunked conn body-bv)) (let-values ([(status resp-headers body keep-alive?) (read-response conn)]) (if keep-alive? (pool-put host port conn) @@ -710,5 +738,3 @@ (def (http-head url . args) (let-values ([(headers params data) (parse-keyword-args args)]) (do-request "HEAD" url headers params #f))) - - --- a/src/jerboa-https/httpd.ss +++ b/src/jerboa-https/httpd.ss @@ -27,7 +27,12 @@ http-respond-chunk-begin http-respond-chunk http-respond-chunk-end ;; Configuration httpd-config) - (import (jerboa prelude) (jerboa-ssl)) + (import + (except (jerboa prelude) + string-trim string-prefix? string-index + tcp-write-string tcp-write tcp-read + tcp-close tcp-accept tcp-listen tcp-connect) + (jerboa-ssl)) ;; ================================================================ ;; Configuration @@ -77,6 +82,17 @@ (and (>= slen plen) (string=? prefix (substring str 0 plen))))) + (def (string-ci-contains? haystack needle) + (let* ([h (string-downcase haystack)] + [n (string-downcase needle)] + [nlen (string-length n)] + [hlen (string-length h)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? n (substring h i (+ i nlen))) #t] + [else (loop (+ i 1))])))) + (def (string-trim-left str) (let ([len (string-length str)]) (let loop ([i 0]) @@ -355,16 +371,20 @@ (def (parse-request-line line) ;; "GET /path?query HTTP/1.1" -> (values method path query version) - (let* ([sp1 (string-index line #\space)] - [method (substring line 0 sp1)] - [rest (substring line (+ sp1 1) (string-length line))] - [sp2 (string-index rest #\space)] - [target (substring rest 0 sp2)] - [version (substring rest (+ sp2 1) (string-length rest))] - [qmark (string-index target #\?)] - [path (if qmark (substring target 0 qmark) target)] - [query (if qmark (substring target (+ qmark 1) (string-length target)) #f)]) - (values method path query version))) + (let ([sp1 (string-index line #\space)]) + (if (not sp1) + (values #f #f #f #f) + (let* ([method (substring line 0 sp1)] + [rest (substring line (+ sp1 1) (string-length line))] + [sp2 (string-index rest #\space)]) + (if (not sp2) + (values #f #f #f #f) + (let* ([target (substring rest 0 sp2)] + [version (substring rest (+ sp2 1) (string-length rest))] + [qmark (string-index target #\?)] + [path (if qmark (substring target 0 qmark) target)] + [query (if qmark (substring target (+ qmark 1) (string-length target)) #f)]) + (values method path query version))))))) (def (read-request reader client-addr) ;; Parse an HTTP request from the reader. @@ -373,9 +393,11 @@ (if (not request-line) #f ;; connection closed (let-values ([(method path query version) (parse-request-line request-line)]) - (let ([headers (read-headers reader)]) - (let ([body (read-request-body reader headers)]) - (make-http-request method path query version headers body client-addr))))))) + (if (not method) + #f + (let ([headers (read-headers reader)]) + (let ([body (read-request-body reader headers)]) + (make-http-request method path query version headers body client-addr)))))))) (def (read-headers reader) ;; Read headers until empty line. Returns alist with lowercase keys. @@ -410,17 +432,21 @@ (def (read-chunked-request-body reader) ;; Read chunked request body. Returns bytevector. - (let loop ([chunks '()]) + (let loop ([chunks '()] [total 0]) (let* ([size-line (reader-read-line reader)] - [chunk-size (string->number (string-trim size-line) 16)]) + [chunk-size (and size-line (string->number (string-trim size-line) 16))]) (cond [(or (not chunk-size) (= chunk-size 0)) (reader-read-line reader) ;; consume trailing \r\n (bytevector-concat-list (reverse chunks))] + [(or (< chunk-size 0) (> (+ total chunk-size) (cfg-ref 5))) + #f] [else (let ([chunk (reader-read-bytes reader chunk-size)]) (reader-read-line reader) ;; consume chunk-trailing \r\n - (loop (cons chunk chunks)))])))) + (if chunk + (loop (cons chunk chunks) (+ total chunk-size)) + #f))])))) (def (string-trim str) (let* ([len (string-length str)] @@ -445,6 +471,21 @@ (bytevector-copy! bv 0 result offset (bytevector-length bv)) (loop (cdr bvs) (+ offset (bytevector-length bv))))))))) + (def (safe-static-relative-path rel) + ;; Reject traversal before appending to the static root. + (if (or (string-prefix? "/" rel) + (string-ci-contains? rel "%2e") + (string-ci-contains? rel "%2f") + (string-ci-contains? rel "%5c")) + #f + (let loop ([parts (string-split rel #\/)]) + (cond + [(null? parts) rel] + [(or (string=? (car parts) "..") + (string=? (car parts) ".")) + #f] + [else (loop (cdr parts))])))) + ;; ================================================================ ;; Response writing ;; ================================================================ @@ -742,9 +783,12 @@ ;; Accept connections and enqueue them for worker threads. (let loop () (unless (unbox stop-box) - (let-values ([(client-fd client-addr) (tcp-accept listen-fd)]) + (let-values ([(client-fd client-addr) + (guard (e [#t (values #f #f)]) + (tcp-accept listen-fd))]) (cond - [(not client-fd) (loop)] ;; EINTR, retry + [(not client-fd) + (unless (unbox stop-box) (loop))] ;; EINTR, retry; closed listener exits [ssl-ctx ;; TLS: set timeout, perform handshake, then enqueue (guard (e [#t @@ -792,13 +836,10 @@ (lambda (req writer) (let* ([path (http-req-path req)] [rel (substring path (string-length url-prefix) (string-length path))] - ;; Prevent directory traversal - [safe-rel (if (or (string-prefix? "/" rel) - (string-prefix? ".." rel)) - "" - rel)] - [file-path (string-append directory "/" safe-rel)]) - (http-respond-file writer req file-path))))) + [safe-rel (safe-static-relative-path rel)]) + (if safe-rel + (http-respond-file writer req (string-append directory "/" safe-rel)) + (http-respond-error writer 403)))))) (def (httpd-start port . args) ;; Start an HTTP server on the given port. @@ -850,9 +891,7 @@ ;; Close listening socket to unblock accept() (tcp-close listen-fd) ;; Send stop sentinel to each worker - (for-each (lambda (_) (wq-enqueue! wq (cons *stop-sentinel* ""))) workers) + (for-each (lambda (_) (wq-enqueue! wq *stop-sentinel*)) workers) ;; Clean up SSL context if HTTPS (when ssl-ctx (ssl-server-ctx-free ssl-ctx)) (display "chez-httpd: stopped\n"))) - -