;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate for CHICKEN.
;; Copyright (c) 2011-2013 by Thomas Chust. All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;; Message base type
(define-record-type message
%make-message #t
type headers
body)
(define (make-message
body #!key
(type "application/octet-stream") (headers '()))
(%make-message type headers body))
(define message-text
(let ((text/plain-rx (irregex '(: bos "text/plain" (or ";" eos)))))
(lambda (msg)
(and (irregex-search text/plain-rx (message-type msg))
(message-body msg)))))
(define (write-message msg #!optional (port (current-output-port)))
(let ((type (message-type msg))
(body (message-body msg)))
(when type
(fprintf port "Content-type: ~a\r\n" type))
(when body
(fprintf port "Content-length: ~a\r\n" (string-length body)))
(for-each
(lambda (header)
(call-with-values (cut car+cdr header)
(cut fprintf port "~a: ~a\r\n" <> <>)))
(message-headers msg))
(display "\r\n" port)
(when body
(display body port))))
;;; Request processing infrastructure
(define max-request-size
(make-parameter #xffff))
(define-values (request-method-handler handled-request-methods)
(let ((handlers (make-hash-table #:test string-ci=? #:hash string-ci-hash)))
(values
(case-lambda
((name)
(hash-table-ref/default handlers name #f))
((name proc)
(hash-table-set! handlers name proc)))
(cut hash-table-keys handlers))))
(define request-body-handler
(let ((handlers (make-hash-table #:test string-ci=? #:hash string-ci-hash)))
(case-lambda
((name)
(hash-table-ref/default handlers name #f))
((name proc)
(hash-table-set! handlers name proc)))))
(define request-parameter-handler
(let ((handler
(lambda (parameters key msg)
(hash-table-update!/default
parameters key (cut append! <> (list msg)) '()))))
(case-lambda
(()
handler)
((proc)
(set! handler proc)))))
(define (parameter-list-ref parameters key #!optional (convert message-text))
(map convert (hash-table-ref/default parameters key '())))
(define (parameter-ref parameters key #!optional (convert message-text))
(and-let* ((vs (hash-table-ref/default parameters key '()))
((pair? vs)))
(convert (car vs))))
;;; Response processing infrastructure
(define-record-type resource-context
%make-resource-context #t
getenv method path)
(define current-resource-context
(make-parameter #f))
(define status-table
(alist->hash-table
'((100 . "Continue")
(101 . "Switching Protocols")
(200 . "Ok")
(201 . "Created")
(202 . "Accepted")
(203 . "Non-Authoritative Information")
(204 . "No Content")
(205 . "Reset Content")
(206 . "Partial Content")
(300 . "Multiple Choices")
(301 . "Moved Permanently")
(302 . "Found")
(303 . "See Other")
(304 . "Not Modified")
(305 . "Use Proxy")
(307 . "Temporary Redirect")
(400 . "Bad Request")
(401 . "Unauthorized")
(402 . "Payment Required")
(403 . "Forbidden")
(404 . "Not Found")
(405 . "Method Not Allowed")
(406 . "Not Acceptable")
(407 . "Proxy Authentication Required")
(408 . "Request Timeout")
(409 . "Conflict")
(410 . "Gone")
(411 . "Length Required")
(412 . "Precondition Failed")
(413 . "Request Entity Too Large")
(414 . "Request-URI Too Long")
(415 . "Unsupported Media Type")
(416 . "Requested Range Not Satisfiable")
(417 . "Expectation Failed")
(500 . "Internal Server Error")
(501 . "Not Implemented")
(502 . "Bad Gateway")
(503 . "Service Unavailable")
(504 . "Gateway Timeout")
(505 . "HTTP Version Not Supported"))
#:test = #:hash number-hash))
(define-record-type (response message)
%make-response #t
status status-message)
(define (make-response
status body #!key
(type (and body "application/octet-stream"))
(headers '())
(status-message
(hash-table-ref/default status-table status "Unknown")))
(%make-response
type headers body
status status-message))
(define (collect-response
status thunk #!key
(type "application/octet-stream")
(headers '())
(status-message
(hash-table-ref/default status-table status "Unknown")))
(%make-response
type headers (with-output-to-string thunk)
status status-message))
(define (make-html-response
status html #!key
(status-message
(hash-table-ref/default status-table status "Unknown"))
(headers '()))
(%make-response
"text/html" headers (call-with-output-string (cut write-html html <>))
status status-message))
(define (make-error-response
status message #!key
(status-message
(hash-table-ref/default status-table status "Unknown"))
(headers '()))
(make-html-response
status
(let ((status-line (sprintf "~a ~a" status status-message)))
`(html
(head
(meta ((name "robots") (content "noindex")))
(title ,status-line))
(body
(h1 ,status-line)
(p ,message))))
#:status-message status-message
#:headers headers))
(define make-redirect-response
(case-lambda
((status target)
(make-error-response
status `(a ((href ,target)) ,target)
#:headers `(("Location" . ,target))))
((target)
(make-error-response
302 `(a ((href ,target)) ,target)
#:headers `(("Location" . ,target))))))
(define (write-response rsp #!optional (port (current-output-port)))
(fprintf
port "Status: ~a ~a\r\n"
(response-status rsp) (response-status-message rsp))
(write-message rsp port))
(define resource-handler
(let ((handlers (make-hash-table)))
(case-lambda
((path)
(let next ((handlers handlers) (args '()) (path path))
(if (pair? path)
(let-values (((step path) (car+cdr path)))
(cond
((hash-table-ref/default handlers step #f)
=> (cut next <> args path))
((hash-table-ref/default handlers #f #f)
=> (cut next <> (cons step args) path))
(else
#f)))
(cond
((hash-table-ref/default handlers #t #f)
=> (lambda (proc)
(lambda (parameters)
(apply proc (reverse! (cons* parameters args))))))
(else
#f)))))
((path proc)
(let next ((handlers handlers) (path path))
(if (pair? path)
(let-values (((step path) (car+cdr path)))
(hash-table-update!
handlers step (cut next <> path) make-hash-table))
(hash-table-set! handlers #t proc))
handlers)
(void)))))
(define-syntax define-resource
(syntax-rules ()
((define-resource (name step/arg ... parameters)
expr ...)
(begin
(define name
(let-syntax ((path
(ir-macro-transformer
(lambda (stx inject id=?)
(let ((steps (cdr stx)))
`(list ,@(map
(lambda (step)
(and (string? step) step))
steps))))))
(path-lambda
(ir-macro-transformer
(lambda (stx inject id=?)
(let ((steps (cadr stx))
(body (cddr stx)))
`(lambda ,(filter-map
(lambda (step)
(and (symbol? step) step))
steps)
,@body))))))
(extend-procedure
(path-lambda (step/arg ... parameters)
expr ...)
(path step/arg ...))))
(resource-handler (procedure-data name) name)))))
(define (write-uri-step step port)
(fprintf port "/~a" (uri-encode step)))
(define (resource-uri res . args)
(call-with-output-string
(lambda (port)
(for-each
(cut write-uri-step <> port)
(string-split
(or ((resource-context-getenv (current-resource-context)) "SCRIPT_NAME")
"")
"/"))
(let next ((steps (procedure-data res)) (args args))
(if (pair? steps)
(let-values (((step steps) (car+cdr steps)))
(if step
(begin
(write-uri-step step port)
(next steps args))
(if (pair? args)
(let-values (((arg args) (car+cdr args)))
(write-uri-step arg port)
(next steps args))
(error 'resource-uri "too few arguments"))))
(unless (null? args)
(error 'resource-uri "too many arguments" args)))))))
;;; Pre-installed default handlers (and directly related stuff)
(define (handle-query-parameters parameters query)
(for-each
(lambda (key+value)
(let-optionals (map uri-decode (string-split key+value "="))
((key #f) (value ""))
(when key
((request-parameter-handler)
parameters key
(make-message value #:type "text/plain")))))
(string-split query "&;"))
#f)
(request-body-handler "application/x-www-form-urlencoded"
(lambda (parameters type size port)
(handle-query-parameters parameters (read-string size port))))
(request-body-handler "multipart/form-data"
(letrec ((boundary-rx
(irregex '(: bow "boundary=" ($ (+ (~ (" ;\n\r\t")))))))
(multipart-boundary
(lambda (s)
(cond
((irregex-search boundary-rx s)
=> (cut irregex-match-substring <> 1))
(else
#f))))
(header-rx
(irregex '(: ($ (+ (~ #\:))) #\: (* space) ($ (*? any))
(or "\r\n" eos))))
(special+regular-headers
(lambda (s start end special)
(partition
(lambda (key+value)
(member (car key+value) special string-ci=?))
(irregex-fold
header-rx
(lambda (start m seed)
(cons (cons (irregex-match-substring m 1)
(irregex-match-substring m 2))
seed))
'() s
(lambda (start seed)
(reverse! seed))
start end))))
(name-rx
(irregex '(: bow "name=" #\" ($ (*? (~ #\"))) #\")))
(disposition-name
(lambda (s default)
(cond
((irregex-search name-rx s)
=> (cut irregex-match-substring <> 1))
(else
default))))
(handle-messages
(lambda (parameters name data boundary)
(let ((boundary-rx
(irregex `(: (or bos "\r\n") "--"
,boundary
(? "--") "\r\n"))))
(irregex-fold
boundary-rx
(lambda (start m skip?)
(and-let* (((not skip?))
(end
(irregex-match-start-index m))
(header-end
(string-contains data "\r\n\r\n" start end))
(body
(substring/shared data (+ header-end 4) end)))
(let-values (((specials headers)
(special+regular-headers
data start header-end
'("Content-type" "Content-length"))))
(let ((type
(alist-ref
"Content-type" specials string-ci=?
"text/plain"))
(name
(disposition-name
(alist-ref
"Content-disposition" headers string-ci=?)
name)))
(when name
(cond
((multipart-boundary type)
=> (cut handle-messages parameters name body <>))
(else
((request-parameter-handler)
parameters name
(make-message
body #:type type #:headers headers))))))))
#f)
#t data))
#f)))
(lambda (parameters type size port)
(cond
((multipart-boundary type)
=> (cut handle-messages
parameters #f (read-string size port) <>))
(else
(make-error-response
501 "The server doesn't know how to parse request parameters from the content type sent."))))))
(request-method-handler "GET"
(lambda (parameters method getenv port)
(handle-query-parameters parameters (or (getenv "QUERY_STRING") ""))))
(request-method-handler "POST"
(lambda (parameters method getenv port)
(or
(handle-query-parameters parameters (or (getenv "QUERY_STRING") ""))
(let ((type (or
(getenv "CONTENT_TYPE")
"application/octet-stream"))
(size (cond
((getenv "CONTENT_LENGTH")
=> string->number)
(else
#f))))
(cond
((not size)
(make-error-response
411 "The server refuses processing as no content length was sent with the request."))
((cond ((max-request-size) => (cut > size <>)) (else #f))
(make-error-response
413 "The server refuses processing as the request's content length is too large."))
((request-body-handler (substring/shared
type 0 (or (string-index type #\;)
(string-length type))))
=> (cut <> parameters type size port))
(else
(make-error-response
501 "The server doesn't know how to parse request parameters from the content type sent.")))))))
;;; Central server routine
(define (handle-request getenv input-port output-port)
(write-response
(handle-exceptions
exn (begin
(when (uncaught-exception? exn)
(set! exn (uncaught-exception-reason exn)))
(print-error-message
exn (current-error-port)
(sprintf "[~a] Request Handling Error" (current-seconds)))
(print-call-chain)
(make-error-response
500 "The server encountered an internal error handling the request."))
(let ((parameters (make-hash-table))
(method (or (getenv "REQUEST_METHOD") "GET"))
(path (string-split (uri-decode (or (getenv "PATH_INFO") "")) "/")))
(or
(cond
((request-method-handler method)
=> (cut <> parameters method getenv input-port))
(else
(make-error-response
405 "The access method used to request the document is not supported."
#:headers
(list
(cons "Allow" (string-join (handled-request-methods) ", "))))))
(cond
((resource-handler path)
=> (lambda (proc)
(current-resource-context
(%make-resource-context
getenv method path))
(current-serialization-context
(make-serialization-context
(current-input-port) input-port
(current-output-port) output-port
(current-error-port)
(current-resource-context) parameters getenv))
(with-limited-continuation
(cut proc parameters))))
(else
(make-error-response
404 "The requested resource was not found by the server.")))
(make-response 204 '()))))
output-port))