WebGate

(require-library
 webgate)

(import
 webgate (only webgate-utils uri-encode))

(define-resource (root parameters)
  (make-html-response
   200
   `(html
     (head
      (meta ((charset "utf-8")))
      (title "WebGate")
      (meta ((name "description") (content "CHICKEN WebGate example")))
      (meta ((name "author") (content "Thomas Chust")))
      (link ((rel "stylesheet") (href "http://twitter.github.com/bootstrap/1.3.0/bootstrap.min.css"))))
     (body
      (div
       ((class "topbar"))
       (div
	((class "fill"))
	(div
	 ((class "container"))
	 (a ((class "brand") (href "#")) "WebGate"))))
      (div
       ((class "container"))
       (div
	((class "hero-unit"))
	(h1 "Application Example")
	(p "This sample program just shows some information extracted from the incoming request."))
       (div
	((class "row"))
	(div
	 ((class "span8"))
	 (h2 "Present Context")
	 (table
	  ((class "zebra-striped"))
	  (thead (tr (th "Key") (th "Value")))
	  (tbody
	   ,@(let ((getenv (resource-context-getenv
			    (current-resource-context))))
	       `((tr (td "SCRIPT_NAME")
		     (td (code ,(or (getenv "SCRIPT_NAME") "<unknown>"))))
		 (tr (td "PATH_INFO")
		     (td (code ,(or (getenv "PATH_INFO") "<unknown>"))))
		 (tr (td "REQUEST_METHOD")
		     (td (code ,(or (getenv "REQUEST_METHOD") "<unknown>")))))))))
	(div
	 ((class "span8"))
	 (h2 "Present Parameters")
	 (table
	  ((class "zebra-striped"))
	  (thead (tr (th "Key") (th "Messages")))
	  (tbody
	   ,@(map
	      (lambda (key+msgs)
		(let-values (((key msgs) (car+cdr key+msgs)))
		  `(tr
		    (td ,key)
		    (td
		     (ol
		      ,@(map
			 (lambda (msg)
			   `(li
			     (p
			      ,(let ((type (message-type msg)))
				 (cond
				  ((string-prefix? "text/plain" type)
				   `(span
				     (span
				      ((class "label notice"))
				      "Text Content:")
				     " "
				     ,(message-body msg)))
				  ((string-prefix? "image/" type)
				   `(span
				     (span
				      ((class "label notice"))
				      "Image Content:")
				     " "
				     (img
				      ((src ,(string-append
					      "data:" type ","
					      (uri-encode
					       (message-body msg))))))))
				  (else
				   `(span
				     (span
				      ((class "label notice"))
				      "Omitted Content:")
				     " "
				     (code ,type)))))
			      ,@(map
				 (lambda (header)
				   (let-values (((key value) (car+cdr header)))
				     `(span
				       ", "
				       (span ((class "label")) ,key ":")
				       " "
				       (code ,value))))
				 (message-headers msg)))))
			 msgs))))))
	      (hash-table->alist parameters))))))
       (div
	((class "row"))
	(div
	 ((class "span8"))
	 (h2 "GET with Parameters")
	 (form
	  ((method "GET") (action ,(resource-uri root)))
	  (fieldset
	   (legend "Stuff")
	   (div
	    ((class "clearfix"))
	    (label ((for "some-thing")) "Some value")
	    (div
	     ((class "input"))
	     (input ((type "text") (id "some-thing") (class "medium")
		     (name "some-thing") (size "30")))))
	   (div
	    ((class "clearfix"))
	    (label ((for "other-things")) "Other values")
	    (div
	     ((class "input"))
	     (select
	      ((id "other-things") (class "medium")
	       (name "other-things") (multiple "multiple"))
	      (option "foobaz")
	      (option "dosh")
	      (option "gostak"))))
	   (div
	    ((class "actions"))
	    (input ((type "submit") (class "btn primary") (value "Submit")))
	    nbsp
	    (input ((type "reset") (class "btn") (value "Reset")))))))
	(div
	 ((class "span8"))
	 (h2 "POST with Parameters")
	 (form
	  ((method "POST") (enctype "multipart/form-data")
	   (action ,(resource-uri root)))
	  (fieldset
	   (legend "Upload")
	   (div
	    ((class "clearfix"))
	    (label ((for "some-thing")) "Some value")
	    (div
	     ((class "input"))
	     (input ((type "text") (id "some-thing") (class "medium")
		     (name "some-thing") (size "30")))))
	   (div
	    ((class "clearfix"))
	    (label ((for "file-thing")) "Some file")
	    (div
	     ((class "input"))
	     (input ((type "file") (id "file-thing") (class "medium")
		     (name "file-thing")))))
	   (div
	    ((class "actions"))
	    (input ((type "submit") (class "btn primary") (value "Submit")))
	    nbsp
	    (input ((type "reset") (class "btn") (value "Reset"))))))))
       (footer copy "2011 by Thomas Chust"))))))

(webgate-main)

;; -*- mode: Scheme; -*-
((category net)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "(S)CGI server library")
 (needs)
 (files "webgate.scm"))

;; -*- mode: Scheme; -*-
;;
;; This file is part of SCGI for CHICKEN
;; Copyright (c) 2011 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.

(require-library
 srfi-1 srfi-4 srfi-13 srfi-18 srfi-69 srfi-99
 data-structures ports extras lolevel irregex tcp)

(module webgate-utils
  (make-uuid uuid?
   uuid-time
   write-netstring read-netstring
   uri-encode uri-decode
   write-html)
  (import
   scheme chicken foreign
   srfi-1 srfi-13 srfi-69
   extras irregex)

;;; UUIDs

(foreign-declare "#include <uuid/uuid.h>")

(define-foreign-type uuid-generator
  (function void ("uuid_t")))

(define (make-uuid #!optional mode)
  (let ((buf (make-string 36)))
    ((foreign-lambda* void ((uuid-generator generate)
			    (nonnull-scheme-pointer buf))
       "uuid_t uuid;"
       "generate(uuid);"
       "uuid_unparse_lower(uuid, buf);")
     (case mode
       ((random)
	(foreign-value "uuid_generate_random" uuid-generator))
       ((time)
	(foreign-value "uuid_generate_time" uuid-generator))
       (else
	(foreign-value "uuid_generate" uuid-generator)))
     buf)
    buf))

(define (uuid? v)
  (and (string? v)
       ((foreign-lambda* bool ((nonnull-c-string buf))
	  "uuid_t uuid;"
	  "C_return(uuid_parse(buf, uuid) == 0);")
	v)))

(define (uuid-time uuid)
  ((foreign-lambda* double ((nonnull-c-string buf))
     "uuid_t uuid;"
     "struct timeval time;"
     "if (uuid_parse(buf, uuid) != 0) C_return(nan(\"bad uuid\"));"
     "uuid_time(uuid, &time);"
     "C_return(((double)time.tv_sec) + ((double)time.tv_usec) / 1.0e6);")
   uuid))

;;; Netstrings

(define (write-netstring s #!optional (port (current-output-port)))
  (fprintf port "~a:~a," (string-length s) s))

(define (read-netstring #!optional (port (current-input-port)))
  (let ((l (string->number (read-token char-numeric? port))))
    (unless l
      (error
       'read-netstring
       "client side protocol error: malformed netstring (bad length)"))
    (unless (eq? (read-char port) #\:)
      (error
       'read-netstring
       "client side protocol error: malformed netstring (bad delimiter)"))
    (let ((s (read-string l port)))
      (unless (eq? (read-char port) #\,)
	(error
	 'read-netstring
	 "client side protocol error: malformed netstring (bad terminal)"))
      s)))

;;; URI encoding

(define uri-encode
  (let ((problematic-rx (irregex '(~ (or alphanumeric
					 "!#$&'()*,-./:;?@_~")))))
    (lambda (s)
      (irregex-replace/all
       problematic-rx s
       (lambda (m)
	 (string-append
	  "%"
	  (string-pad
	   (number->string
	    (char->integer (string-ref (irregex-match-substring m) 0)) 16)
	   2 #\0)))))))

(define uri-decode
  (let ((escape-rx (irregex '(or #\+ (: #\% ($ (= 2 hex-digit)))))))
    (lambda (s)
      (irregex-replace/all
       escape-rx s
       (lambda (m)
	 (case (string-ref s (irregex-match-start-index m))
	   ((#\+)
	    " ")
	   ((#\%) 
	    (string
	     (integer->char
	      (string->number (irregex-match-substring m 1) 16))))))))))

;;; HTML output

(define write-html
  (letrec ((tag-rules
	    (alist->hash-table
	     '((area . void)
	       (base . void)
	       (br . void)
	       (col . void)
	       (command . void)
	       (embed . void)
	       (hr . void)
	       (img . void)
	       (input . void)
	       (keygen . void)
	       (link . void)
	       (meta . void)
	       (param . void)
	       (source . void)
	       (track . void)
	       (wbr . void)
	       (script . raw)
	       (style . raw))
	     #:test eq? #:hash eq?-hash))
	   (problematic-rx
	    (irregex '("\"&<>")))
	   (html-escape
	    (lambda (s)
	      (irregex-replace/all
	       problematic-rx s
	       (lambda (m)
		 (case (string-ref (irregex-match-substring m) 0)
		   ((#\") "&quot;")
		   ((#\&) "&amp;")
		   ((#\<) "&lt;")
		   ((#\>) "&gt;"))))))
	   (write-element
	    (lambda (elt port)
	      (unless (and (pair? elt) (symbol? (car elt)) (list? (cdr elt)))
		(error
		 'write-html "not a proper element"
		 elt))
	      (let-values (((tag attributes+contents)
			    (car+cdr elt)))
		(fprintf port "<~a" tag)
		(let-values (((rule)
			      (hash-table-ref/default tag-rules tag 'normal))
			     ((attributes contents)
			      (cond
			       ((null? attributes+contents)
				(values '() '()))
			       ((and (list? (car attributes+contents))
				     (every list? (car attributes+contents)))
				(car+cdr attributes+contents))
			       (else
				(values '() attributes+contents)))))
		  (for-each (cut write-attribute <> port) attributes)
		  (display #\> port)
		  (case rule
		    ((normal)
		     (for-each (cut write-content #t <> port) contents))
		    ((raw)
		     (for-each (cut write-content #f <> port) contents))
		    ((void)
		     (unless (null? contents)
		       (error
			'write-html "void elements cannot have contents"
			elt))))
		  (case rule
		    ((normal raw)
		     (fprintf port "</~a>" tag)))))))
	   (write-attribute
	    (lambda (attr port)
	      (unless (and (pair? attr) (symbol? (car attr)) (list? (cdr attr)))
		(error
		 'write-html "not a proper attribute"
		 attr))
	      (let-values (((key contents) (car+cdr attr)))
		(fprintf port " ~a=\"" key)
		(for-each (cut write-content #f <> port) contents)
		(display #\" port))))
	   (write-content
	    (lambda (allow-elements? v port)
	      (cond
	       ((symbol? v)
		(fprintf port "&~a;" v))
	       ((and (integer? v) (positive? v))
		(fprintf port "&#~a;" v))
	       ((string? v)
		(display (html-escape v) port))
	       (allow-elements?
		(write-element v port))
	       (else
		(error
		 'write-html "element not allowed in this context"
		 v))))))
    (lambda (html #!optional (port (current-output-port)))
      (display "<!DOCTYPE html>" port)
      (newline port)
      (write-element html port)
      (newline port))))

)

(module webgate-core
  (message make-message message?
   message-type message-headers message-body
   write-message
   max-request-size
   request-method-handler
   request-body-handler
   request-parameter-handler
   resource-context current-resource-context resource-context?
   resource-context-getenv resource-context-return
   response make-response response?
   collect-response make-html-response make-error-response
   response-status response-status-message
   write-response
   resource-handler define-resource resource-uri
   handle-query-parameters
   handle-request)
  (import
   scheme chicken
   srfi-1 srfi-4 srfi-13 srfi-18 srfi-69 srfi-99
   data-structures ports extras lolevel irregex webgate-utils)

;;; 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 (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)))))

;;; Response processing infrastructure

(define-record-type resource-context
  %make-resource-context #t
  getenv return)

(define (current-resource-context)
  (let ((ctx (thread-specific (current-thread))))
    (and (resource-context? ctx) ctx)))

(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 (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 (resource-uri res . args)
  (uri-encode
   (call-with-output-string
    (lambda (port)
      (for-each
       (cut fprintf port "/~a" <>)
       (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
		    (fprintf port "/~a" step)
		    (next steps args))
		  (if (pair? args)
		      (let-values (((arg args) (car+cdr args)))
			(fprintf port "/~a" arg)
			(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
	  (print-error-message exn)
	  (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)
	      (thread-join!
	       (thread-start!
		(make-thread
		 (lambda ()
		   (call-with-current-continuation
		    (lambda (return)
		      (thread-specific-set!
		       (current-thread)
		       (%make-resource-context getenv return))
		      (proc parameters)))))))))
	(else
	 (make-error-response
	  404 "The requested resource was not found by the server.")))
       (make-response 204 '()))))
   output-port))

)

(module webgate-suspend
  (max-suspended-resources
   suspended-resource-handler
   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-18 srfi-69
   data-structures webgate-utils webgate-core)

;;; Support for suspended computations (and directly related stuff)

(define max-suspended-resources
  (make-parameter 1024))

(define suspended-resource-handler
  (let ((handler
	 (let ((mutex (make-mutex 'suspended-resources))
	       (table (make-hash-table
		       #:test string-ci=? #:hash string-ci-hash
		       #:size (max-suspended-resources))))
	   (lambda (resume/uuid)
	     (dynamic-wind
		 (cut mutex-lock! mutex)
		 (if (procedure? resume/uuid)
		     (lambda ()
		       (let ((size (hash-table-size table)))
			 (when (>= size (max-suspended-resources))
			   (let ((uuids (sort! (hash-table-keys table)
					       (lambda (a b)
						 (< (uuid-time a)
						    (uuid-time b))))))
			     (for-each
			      (cut hash-table-delete! table <>)
			      (take uuids
				    (inexact->exact (ceiling (/ size 2))))))))
		       (let ((uuid (make-uuid 'time)))
			 (hash-table-set! table uuid resume/uuid)
			 uuid))
		     (lambda ()
		       (hash-table-ref/default table resume/uuid #f)))
		 (cut mutex-unlock! mutex))))))
    (case-lambda
     (()
      handler)
     ((proc)
      (set! handler proc)))))

(define-resource (suspended "suspended" uuid parameters)
  (cond
   (((suspended-resource-handler) uuid)
    => (cut <> parameters))
   (else
    (make-error-response
     404 "The requested suspended resource was not found on the server."))))

(define (send/suspend proc)
  (call-with-current-continuation
   (lambda (resume)
     (let ((uuid ((suspended-resource-handler) resume)))
       ((resource-context-return (current-resource-context))
	(proc (resource-uri suspended uuid)))))))

)

(module webgate-cgi
  (cgi-main-loop)
  (import
   scheme chicken)

;;; CGI server "loop"

(define (cgi-main-loop handle-request)
  (handle-request 
   get-environment-variable
   (current-input-port) (current-output-port)))

)

(module webgate-scgi
  (scgi-main-loop)
  (import
   scheme chicken
   srfi-13 srfi-18 srfi-69
   data-structures irregex webgate-utils tcp)

;;; SCGI server loop (and directly related stuff)

(define (scgi-main-loop handle-request listener)
  (let ((environment-rx
	 (irregex '(: ($ (* (~ #\nul))) #\nul ($ (* (~ #\nul))) #\nul))))
    (let loop ()
      (let-values (((input-port output-port) (tcp-accept listener)))
	(thread-start!
	 (make-thread
	  (lambda ()
	    (let ((environment
		   (irregex-fold
		    environment-rx
		    (lambda (start m environment)
		      (hash-table-set!
		       environment (irregex-match-substring m 1)
		       (irregex-match-substring m 2))
		      environment)
		    (make-hash-table #:test string=? #:hash string-hash)
		    (read-netstring input-port))))
	      (handle-request
	       (cut hash-table-ref/default environment <> #f)
	       input-port output-port))
	    (close-input-port input-port)
	    (close-output-port output-port))))
	(loop)))))

)

(module webgate
  (message make-message message?
   message-type message-headers message-body
   max-request-size
   request-method-handler
   request-body-handler
   request-parameter-handler
   resource-context current-resource-context resource-context?
   resource-context-getenv resource-context-return
   response make-response response?
   collect-response make-html-response make-error-response
   response-status response-status-message
   resource-handler define-resource resource-uri
   max-suspended-resources
   suspended-resource-handler
   suspended
   send/suspend
   webgate-main)
  (import
   scheme chicken
   webgate-core webgate-suspend webgate-cgi webgate-scgi tcp)

(define (webgate-main #!optional (arguments (command-line-arguments)))
  (let-optionals arguments ((port #f) (backlog "4") (host "localhost"))
    (if port
	(let ((port (or (string->number port)
			(error 'webgate-main "bad port number" port)))
	      (backlog (or (string->number backlog)
			   (error 'webgate-main "bad backlog number" backlog))))
	  (scgi-main-loop handle-request (tcp-listen port backlog host)))
	(cgi-main-loop handle-request))))

)

;; -*- mode: Scheme; -*-
(compile -s -O2 -d1 "webgate.scm" -luuid
	 -j webgate
	 -j webgate-utils
	 -j webgate-core
	 -j webgate-suspend
	 -j webgate-cgi
	 -j webgate-scgi)

(compile -c -O2 -d1 "webgate.scm")

(compile -s -O2 -d0 "webgate.import.scm")
(compile -s -O2 -d0 "webgate-utils.import.scm")
(compile -s -O2 -d0 "webgate-core.import.scm")
(compile -s -O2 -d0 "webgate-suspend.import.scm")
(compile -s -O2 -d0 "webgate-cgi.import.scm")
(compile -s -O2 -d0 "webgate-scgi.import.scm")

(install-extension
 'webgate
 '("webgate.so" "webgate.o"
   "webgate.import.so"
   "webgate-utils.import.so"
   "webgate-core.import.so"
   "webgate-suspend.import.so"
   "webgate-cgi.import.so"
   "webgate-scgi.import.so")
 '((version "1.0.0")
   (static "webgate.o")
   (static-options "-luuid")))