220 lines
9.3 KiB
Scheme
220 lines
9.3 KiB
Scheme
(define FCGI-BEGIN-REQUEST 1)
|
|
(define FCGI-ABORT-REQUEST 2)
|
|
(define FCGI-END-REQUEST 7)
|
|
(define FCGI-PARAMS 4)
|
|
(define FCGI-STDIN 5)
|
|
(define FCGI-STDOUT 6)
|
|
(define FCGI-STDERR 7)
|
|
(define FCGI-DATA 8)
|
|
(define FCGI-GET-VALUES 9)
|
|
(define FCGI-GET-VALUES-RESULT 10)
|
|
(define FCGI-UNKNOWN-TYPE 11)
|
|
|
|
(define (fcgi-type->symbol type)
|
|
(cond ((= type FCGI-BEGIN-REQUEST) 'FCGI-BEGIN-REQUEST)
|
|
((= type FCGI-ABORT-REQUEST) 'FCGI-ABORT-REQUEST)
|
|
((= type FCGI-END-REQUEST) 'FCGI-END-REQUEST)
|
|
((= type FCGI-PARAMS) 'FCGI-PARAMS)
|
|
((= type FCGI-STDIN) 'FCGI-STDIN)
|
|
((= type FCGI-STDOUT) 'FCGI-STDOUT)
|
|
((= type FCGI-STDERR) 'FCGI-STDERR)
|
|
((= type FCGI-DATA) 'FCGI-DATA)
|
|
((= type FCGI-GET-VALUES) 'FCGI-GET-VALUES)
|
|
((= type FCGI-GET-VALUES-RESULT) 'FCGI-GET-VALUES-RESULT)
|
|
((= type FCGI-UNKNOWN-TYPE) 'FCGI-UNKNOWN-TYPE)))
|
|
|
|
(define FCGI-KEEP-CONN 1)
|
|
|
|
(define FCGI-RESPONDER 1)
|
|
(define FCGI-AUTHORIZER 2)
|
|
(define FCGI-FILTER 3)
|
|
|
|
(define (fcgi-role->symbol role)
|
|
(cond ((= role FCGI-RESPONDER) 'FCGI-RESPONDER)
|
|
((= role FCGI-AUTHORIZER) 'FCGI-AUTHORIZER)
|
|
((= role FCGI-FILTER) 'FCGI-FILTER)))
|
|
|
|
(define (b1+b0 b1 b0)
|
|
;; https://web.archive.org/web/20160119141816/http://www.fastcgi.com/drupal/node/6?q=node%2F22
|
|
;; FROM SPECIFICATION:
|
|
;; When two adjacent structure components are named identically except for
|
|
;; the suffixes "B1" and "B0," it means that the two components may be viewed
|
|
;; as a single number, computed as B1<<8 + B0
|
|
;; BUT IN CODE THEY DO: (B1<<8) + B0
|
|
(+ (arithmetic-shift b1 8) b0))
|
|
|
|
(define (integer->b1-b0 int)
|
|
(let ((b1 (bitwise-and (arithmetic-shift int -8) 255))
|
|
(b0 (bitwise-and int 255)))
|
|
`((b1 . ,b1) (b0 . ,b0))))
|
|
|
|
(define (parse-request-content type content)
|
|
(cond
|
|
((symbol=? type 'FCGI-BEGIN-REQUEST)
|
|
(let ((role-b1 (bytevector-u8-ref content 0))
|
|
(role-b0 (bytevector-u8-ref content 1))
|
|
(flags (bytevector-u8-ref content 2)))
|
|
`((role . ,(b1+b0 role-b1 role-b0))
|
|
(flags . ,flags))))
|
|
((symbol=? type 'FCGI-PARAMS)
|
|
;; https://web.archive.org/web/20160119141816/http://www.fastcgi.com/drupal/node/6?q=node%2F22
|
|
;; 3.4 Name-Value Pairs
|
|
(letrec*
|
|
((>>7 (lambda (n) (exact (floor (* n (expt 2 -7))))))
|
|
(read-length
|
|
(lambda (bv start-index)
|
|
(let*
|
|
((b0 (bytevector-u8-ref bv (+ start-index 0)))
|
|
(b0>>7 (>>7 b0))
|
|
(b3 (if (= b0>>7 0) 0 b0))
|
|
(b2 (if (= b0>>7 0) 0 (bytevector-u8-ref bv (+ start-index 1))))
|
|
(b1 (if (= b0>>7 0) 0 (bytevector-u8-ref bv (+ start-index 2))))
|
|
;; Notice redefinition of b0
|
|
(b0 (if (= b0>>7 0) b0 (bytevector-u8-ref bv (+ start-index 3))))
|
|
(bytes-in-length (if (= b0>>7 0) 1 4)))
|
|
(cons bytes-in-length
|
|
(if (= b0>>7 0)
|
|
b0
|
|
;; ((B3 & 0x7f) << 24) + (B2 << 16) + (B1 << 8) + B0
|
|
(+ (arithmetic-shift (bitwise-and b3 127) 24)
|
|
(arithmetic-shift b2 16)
|
|
(arithmetic-shift b1 8)
|
|
b0))))))
|
|
(content-length (bytevector-length content))
|
|
(looper
|
|
(lambda (start-index result)
|
|
(if (>= start-index content-length)
|
|
result
|
|
(let*
|
|
((name-length (read-length content start-index))
|
|
(value-length
|
|
(read-length content (+ start-index (car name-length))))
|
|
(lengths-length (+ (car name-length) (car value-length)))
|
|
(name (string->symbol
|
|
(utf8->string
|
|
(bytevector-copy content
|
|
(+ start-index lengths-length)
|
|
(+ start-index
|
|
lengths-length
|
|
(cdr name-length))))))
|
|
(value (utf8->string
|
|
(bytevector-copy content
|
|
(+ start-index
|
|
lengths-length
|
|
(cdr name-length))
|
|
(+ start-index
|
|
lengths-length
|
|
(cdr name-length)
|
|
(cdr value-length))))))
|
|
(looper (+ start-index
|
|
lengths-length
|
|
(cdr name-length)
|
|
(cdr value-length))
|
|
(append result (list (cons name value)))))))))
|
|
(if (= content-length 0)
|
|
(bytevector)
|
|
(looper 0 '()))))
|
|
((symbol=? type 'FCGI-STDIN)
|
|
(utf8->string content))
|
|
(else content)))
|
|
|
|
(define (read-request socket)
|
|
(let* ((fields (socket-recv socket 8))
|
|
(version (bytevector-u8-ref fields 0))
|
|
(type (bytevector-u8-ref fields 1))
|
|
(type-symbol (fcgi-type->symbol type))
|
|
(request-id-b1 (bytevector-u8-ref fields 2))
|
|
(request-id-b0 (bytevector-u8-ref fields 3))
|
|
(request-id (b1+b0 request-id-b1 request-id-b0))
|
|
(content-length-b1 (bytevector-u8-ref fields 4))
|
|
(content-length-b0 (bytevector-u8-ref fields 5))
|
|
(content-length (b1+b0 content-length-b1 content-length-b0))
|
|
(padding-length (bytevector-u8-ref fields 6))
|
|
(reserved (bytevector-u8-ref fields 7))
|
|
(content-data (if (> content-length 0)
|
|
(socket-recv socket content-length)
|
|
(bytevector)))
|
|
(padding-data (if (> padding-length 0)
|
|
(socket-recv socket padding-length)
|
|
(bytevector))))
|
|
(when (not (= version 1)) (error "Unsupported fastcgi version" version))
|
|
`(,type-symbol
|
|
(id . ,request-id)
|
|
(content . ,(parse-request-content type-symbol content-data)))))
|
|
|
|
(define (read-requests socket result)
|
|
(let ((request (read-request socket)))
|
|
(if (symbol=? (car request) 'FCGI-STDIN)
|
|
(reverse (cons request result))
|
|
(read-requests socket (cons request result)))))
|
|
|
|
(define (write-response socket type id response-bytes)
|
|
(let* ((version 1)
|
|
(header-bytes
|
|
(let* ((bytes (make-bytevector 8 0))
|
|
(id-b1-b0 (integer->b1-b0 id))
|
|
(content-length (bytevector-length response-bytes))
|
|
(content-length-b1-b0 (integer->b1-b0 content-length))
|
|
(padding-length 0)
|
|
(reserved 0))
|
|
(bytevector-u8-set! bytes 0 version)
|
|
(bytevector-u8-set! bytes 1 type)
|
|
(bytevector-u8-set! bytes 2 (cdr (assoc 'b1 id-b1-b0)))
|
|
(bytevector-u8-set! bytes 3 (cdr (assoc 'b0 id-b1-b0)))
|
|
(bytevector-u8-set! bytes 4 (cdr (assoc 'b1 content-length-b1-b0)))
|
|
(bytevector-u8-set! bytes 5 (cdr (assoc 'b0 content-length-b1-b0)))
|
|
(bytevector-u8-set! bytes 6 padding-length)
|
|
(bytevector-u8-set! bytes 7 reserved)
|
|
bytes))
|
|
(response (bytevector-append header-bytes response-bytes)))
|
|
(socket-send socket response)))
|
|
|
|
(define (check-role role)
|
|
(if (= role FCGI-RESPONDER)
|
|
role
|
|
(error "Unsupported fastcgi role" (fcgi-role->symbol role))))
|
|
|
|
(define fcgi-internal-handle
|
|
(lambda (client-socket thunk)
|
|
(let*
|
|
((requests (read-requests client-socket '()))
|
|
(begin-request (cdr (assoc 'FCGI-BEGIN-REQUEST requests)))
|
|
(begin-request-content (cdr (assoc 'content begin-request)))
|
|
(id (cdr (assoc 'id begin-request)))
|
|
(role (check-role (cdr (assoc 'role begin-request-content))))
|
|
(flags (cdr (assoc 'flags begin-request-content)))
|
|
(params-request (cdr (assoc 'FCGI-PARAMS requests)))
|
|
(headers (cdr (assoc 'content params-request)))
|
|
(content-length (string->number (cdr (assoc 'CONTENT_LENGTH headers))))
|
|
(query-string (cdr (assoc 'QUERY_STRING headers)))
|
|
(parameters '()) ;; TODO
|
|
(stdin-request (cdr (assoc 'FCGI-STDIN requests)))
|
|
(body (cdr (assoc 'content stdin-request)))
|
|
(files '()) ;; TODO
|
|
(request '())
|
|
(response (parameterize
|
|
((current-output-port (open-output-string)))
|
|
(apply thunk
|
|
(list request
|
|
headers
|
|
parameters
|
|
'() ;; TODO Cookies
|
|
body
|
|
files))
|
|
(get-output-string (current-output-port)))))
|
|
(write-response client-socket FCGI-STDOUT id (string->utf8 response))
|
|
(write-response client-socket FCGI-STDERR id (make-bytevector 0))
|
|
(write-response client-socket FCGI-END-REQUEST id (make-bytevector 0))
|
|
(socket-close client-socket))))
|
|
|
|
(define fcgi-listen
|
|
(lambda (socket thunk)
|
|
(fcgi-internal-handle (socket-accept socket) thunk)
|
|
(fcgi-listen socket thunk)))
|
|
|
|
(define (handle-request options thunk)
|
|
(let ((port (assoc 'port options)))
|
|
(when (not port)
|
|
(error "handle-request (fcgi) requires port to be passed in options, example: '((port . \"3000\"))"))
|
|
(fcgi-listen (make-server-socket (cdr port) *af-inet* *sock-stream* *ipproto-ip*) thunk)))
|