WebGate

;; 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.

(eval-when (compile eval load)
  (require-library webgate))

(eval-when (compile eval)
  (import (only webgate-utils use-at-read-table))
  (use-at-read-table #:list-arguments? #t))

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

(define common-head
  '@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")]
     @style[(type "text/css")]{body{padding-top:60px}}
   })

(define-resource (root parameters)
  (make-html-response
   200
   `@html{
      @,common-head
      @body{

        @div[(class "topbar")]{

          @div[(class "fill")]{

	    @div[(class "container")]{
	      @a[(class "brand") (href "#")]{WebGate}

	      @ul[(class "nav")]{
	        @li[(class "active")]{@a[(href "#")]{Miscellaneous}}
	        @li{@a[(href ,(resource-uri calc "add"))]{Suspensions}}

	      }
	    }
	  }
        }
        @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-thing0")]{Some value}

		    @div[(class "input")]{
		      @input[(type "text") (id "some-thing0") (class "medium")
			     (name "some-thing") (size "30")]

		    }
		  }
		  @div[(class "clearfix")]{
		    @label[(for "other-things0")]{Other values}

		    @div[(class "input")]{

		      @select[(id "other-things0") (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-thing1")]{Some value}

		    @div[(class "input")]{
		      @input[(type "text") (id "some-thing1") (class "medium")
			     (name "some-thing") (size "30")]

		    }
		  }
		  @div[(class "clearfix")]{
		    @label[(for "file-thing1")]{Some file}

		    @div[(class "input")]{
		      @input[(type "file") (id "file-thing1") (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}
	}
      }
    }))

(define (numeric-parameter parameters key)
  (cond
   ((hash-table-ref/default parameters key #f)
    => (lambda (msgs)
	 (and (not (null? msgs))
	      (string->number (message-body (car msgs))))))
   (else
    #f)))

(define-resource (calc "calc" op parameters)
  (if (string=? op "add")
      (let* ((common-topbar

	      `@div[(class "topbar")]{

		 @div[(class "fill")]{

		   @div[(class "container")]{
		     @a[(class "brand") (href "#")]{WebGate}

		     @ul[(class "nav")]{
		       @li{@a[(href ,(resource-uri root))]{Miscellaneous}}
		       @li[(class "active")]{@a[(href "#")]{Suspensions}}
		     }
		   }
		 }
	       })
	     (parameters
	      (send/suspend
	       (lambda (resume-uri)
		 (make-html-response
		  200
		  `@html{
		     @,common-head
		     @body{
		       @,common-topbar

		       @div[(class "container")]{

		         @form[(method "GET") (action ,resume-uri)]{
			   @fieldset{
			     @legend{Add Numbers}

			     @div[(class "clearfix")]{
			       @label[(for "a")]{First Summand}

			       @div[(class "input")]{
			         @input[(type "text") (id "a") (class "medium")
					(name "a") (size "30")]

			       }
			     }
			     @div[(class "clearfix")]{
			       @label[(for "a")]{Second Summand}

			       @div[(class "input")]{
			         @input[(type "text") (id "b") (class "medium")
					(name "b") (size "30")]

			       }
			     }
			     @div[(class "actions")]{
			       @input[(type "submit") (class "btn primary")
				      (value "Submit")]
			       @nbsp
			       @input[(type "reset") (class "btn")
				      (value "Reset")]
			     }
			   }
			 }
		       }
		     }
		   }))))
	     (a
	      (or (numeric-parameter parameters "a") 0))
	     (b
	      (or (numeric-parameter parameters "b") 0)))
	(make-html-response
	 200
	 `@html{
	    @,common-head
	    @body{
	      @,common-topbar

	      @div[(class "container")]{

	        @div[(class "hero-unit")]{
		  @h1{@,(number->string (+ a b))}
		  @p{@hellip is the answer}
		}
	      }
	    }
	  }))
      (make-error-response
       400 "Don't know how to perform the requested calculation.")))

(webgate-main)

;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate 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.

;;; CGI server "loop"

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

;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate 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.

;;; 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
	  (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)
	      (thread-join!
	       (thread-start!
		(make-thread
		 (lambda ()
		   (call-with-current-continuation
		    (lambda (return)
		      (thread-specific-set!
		       (current-thread)
		       (%make-resource-context getenv return))
		      (let ((rsp (proc parameters)))
			((resource-context-return (current-resource-context))
			 rsp))))))))))
	(else
	 (make-error-response
	  404 "The requested resource was not found by the server.")))
       (make-response 204 '()))))
   output-port))

;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate 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.

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

;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate 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.

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

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

(define max-suspended-resources-load
  (make-parameter 0.75))

(define suspended-resource-handler
  (let ((handler
	 (let ((mutex (make-mutex 'suspended-resources)))
	   (mutex-specific-set!
	    mutex (make-hash-table #:test string-ci=? #:hash string-ci-hash))
	   (lambda (resume/uuid)
	     (dynamic-wind
		 (cut mutex-lock! mutex)
		 (lambda ()
		   (let ((table (mutex-specific mutex)))
		     (if (procedure? resume/uuid)
			 (let ((size (hash-table-size table))
			       (max-size (max-suspended-resources)))
			   (when (>= size max-size)
			     (let* ((max-load (max-suspended-resources-load))
				    (num-drop (- size (* max-size max-load))))
			       (for-each
				(cut hash-table-delete! table <>)
				(take
				 (sort! (hash-table-keys table)
					(lambda (a b)
					  (< (uuid-time a) (uuid-time b))))
				 (inexact->exact (ceiling num-drop))))))
			   (let ((uuid (make-uuid 'time)))
			     (hash-table-set! table uuid resume/uuid)
			     uuid))
			 (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)))))))

;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate 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.

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

;;; @-expressions

(define (make-at-reader #!key
			(command-char #\@)
			(trim-whitespace? #t)
			(condense-whitespace? #t)
			(list-arguments? #f)
			(inside? #f))
  (letrec ((char-normal?
	    (cute char-set-contains?
		  (char-set-complement
		   (char-set command-char #\{ #\} #\return #\newline))
		  <>))
	   (char-group?
	    (cute char-set-contains?
		  (char-set #\[ #\{)
		  <>))
	   (skip-whitespace
	    (lambda (port)
	      (when (char-whitespace? (peek-char port))
		(read-char port)
		(skip-whitespace port))))
	   (read-whitespace
	    (if condense-whitespace?
		(lambda (port)
		  (skip-whitespace port)
		  " ")
		(cut read-token char-whitespace? <>)))
	   (read-at-exp
	    (lambda (port)
	      (skip-whitespace port)
	      (let ((char (peek-char port)))
		(cond
		 ((eof-object? char)
		  (read-char port))
		 (else
		  (when (eqv? char command-char)
		    (read-char port))
		  (let* ((head (and (not (char-group? (peek-char port)))
				    (read port)))
			 (args (and (eqv? (peek-char port) #\[)
				    (read port)))
			 (body (and (eqv? (peek-char port) #\{)
				    (read-inside-at-exp 'skip port))))
		    (if (or args body)
			(append!
			 (cond
			  (head => list)
			  (else '()))
			 (cond
			  ((and list-arguments? args) => list)
			  (else (or args '())))
			 (or body '()))
			head)))))))
	   (read-inside-at-exp
	    (lambda (brace-mode port)
	      (append!
	       (let ((head
		      (case brace-mode
			((none)
			 '())
			((skip)
			 (and (eqv? (peek-char port) #\{)
			      (begin (read-char port) '())))
			(else
			 (and (eqv? (peek-char port) #\{)
			      (list (string (read-char port))))))))
		 (if head
		     (begin
		       (when trim-whitespace? (skip-whitespace port))
		       head)
		     (syntax-error
		      'read-inside-at-exp "expected @-expression body, found"
		      (peek-char port))))
	       (let more ()
		 (let ((char (peek-char port)))
		   (cond
		    ((eqv? char #\{)
		     (case brace-mode
		       ((none)
			(cons (string (read-char port)) (more)))
		       (else
			(append! (read-inside-at-exp 'keep port) (more)))))
		    ((eqv? char #\})
		     (case brace-mode
		       ((none)
			(cons (string (read-char port)) (more)))
		       ((skip)
			(read-char port)
			'())
		       (else
			(list (string (read-char port))))))
		    ((eof-object? char)
		     (case brace-mode
		       ((none)
			(read-char port)
			'())
		       (else
			(syntax-error
			 'read-inside-at-exp "@-expression body not closed"))))
		    ((eqv? char command-char)
		     (cons (read-at-exp port) (more)))
		    ((char-whitespace? char)
		     (let* ((head (read-whitespace port))
			    (tail (more)))
		       (if (or (pair? tail) (not trim-whitespace?))
			   (cons head tail)
			   tail)))
		    (else
		     (cons (read-token char-normal? port) (more))))))))))
    (if inside?
	(lambda (#!optional (port (current-input-port)))
	  (read-inside-at-exp 'none port))
	(lambda (#!optional (port (current-input-port)))
	  (read-at-exp port)))))

(define (use-at-read-table #!rest args #!key
			   (command-char #\@)
			   (read-table (current-read-table)))
  (current-read-table (copy-read-table read-table))
  (set-read-syntax! command-char (apply make-at-reader #:inside? #f args)))

(define (make-at-read-table #!rest args #!key
			    (read-table (current-read-table)))
  (parameterize ((current-read-table read-table))
    (apply use-at-read-table args)
    (current-read-table)))

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

;; -*- mode: Scheme; -*-
((category net)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "(S)CGI web application framework")
 (needs srfi-99)
 (files "webgate.scm"
	"webgate-utils.scm"
	"webgate-core.scm"
	"webgate-suspend.scm"
	"webgate-cgi.scm"
	"webgate-scgi.scm"))

;; 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-14 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
   make-at-reader make-at-read-table use-at-read-table
   uri-encode uri-decode
   write-html)
  (import
   scheme chicken foreign
   srfi-1 srfi-13 srfi-14 srfi-69
   data-structures extras irregex)
  (include

   "webgate-utils.scm"))


































































































































































































(module webgate-core
  (message make-message message?
   message-type message-headers message-body
   write-message
   max-request-size
   request-method-handler

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

   "webgate-core.scm"))



























































































































































































































































































































































































































































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

   "webgate-suspend.scm"))

























































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

   "webgate-cgi.scm"))







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

   "webgate-scgi.scm"))



























(module webgate
  (message make-message message?
   message-type message-headers message-body
   max-request-size
   request-method-handler
   request-body-handler