WebGate

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

(require-library webgate)
(import (only webgate-utils use-at-read-table))
(use-at-read-table #:list-arguments? #t)

;; -*- 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
................................................................................
;; 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}
................................................................................
			     (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
................................................................................
		    @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)
................................................................................
	      @,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-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
................................................................................
;; 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 (eval load)
  (require-library webgate))

;; Use -extend at-expr during compilation!
(eval-when (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")]
     @meta[(name "viewport") (content "width=device-width, initial-scale=1.0")]
     @title{WebGate}
     @meta[(name "description") (content "CHICKEN WebGate example")]
     @meta[(name "author") (content "Thomas Chust")]
     @link[(rel "stylesheet") (href "/css/bootstrap.min.css")]
     @link[(rel "stylesheet") (href "/css/bootstrap-responsive.min.css")]
     @style[(type "text/css")]{body{padding-top:60px; padding-bottom:40px}}
   })

(define common-foot
  '@{
    @script[(src "/js/jquery.min.js")]
    @script[(src "/js/bootstrap.min.js")]
   })

(define-resource (root parameters)
  (make-html-response
   200
   `@html{
      @,common-head
      @body{
        @div[(class "navbar navbar-inverse navbar-fixed-top")]{
          @div[(class "navbar-inner")]{
	    @div[(class "container")]{
	      @a[(class "brand") (href "#")]{WebGate}
	      @div[(class "nav-collapse collapse")]{
	        @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}
................................................................................
			     (ol
			      ,@(map
				 (lambda (msg)
				   `(li
				     (p
				      ,(let ((type (message-type msg)))
					 (cond
					  ((message-text msg)
					   => (lambda (txt)
						`(span
						  (span
						   ((class "label notice"))
						   "Text Content:")
						  " " ,txt)))

					  ((string-prefix? "image/" type)
					   `(span
					     (span
					      ((class "label notice"))
					      "Image Content:")
					     " "
					     (img
................................................................................
		    @input[(type "reset") (class "btn")
			   (value "Reset")]
		  }
		}
	      }
	    }
	  }
	  @footer{@copy 2011-2013 by Thomas Chust}
	}
	@,@common-foot
      }
    }))

(define numeric-parameter
  (cute
   parameter-ref <> <>
   (lambda (v)
     (cond
      ((message-text v) => string->number)
      (else #f)))))


(define-resource (calc "calc" op parameters)
  (if (string=? op "add")
      (let* ((common-topbar
	      `@div[(class "navbar navbar-inverse navbar-fixed-top")]{
		 @div[(class "navbar-inner")]{
		   @div[(class "container")]{
		     @a[(class "brand") (href "#")]{WebGate}
		     @div[(class "nav-collapse collapse")]{
		       @ul[(class "nav")]{
		         @li{@a[(href ,(resource-uri root))]{Miscellaneous}}
		         @li[(class "active")]{@a[(href "#")]{Suspensions}}
		       }
		     }
		   }
		 }
	       })
	     (parameters
	      (send/suspend
	       (lambda (resume-uri)
................................................................................
	      @,common-topbar
	      @div[(class "container")]{
	        @div[(class "hero-unit")]{
		  @h1{@,(number->string (+ a b))}
		  @p{@hellip is the answer}
		}
	      }
	      @,@common-foot
	    }
	  }))
      (make-error-response
       400 "Don't know how to perform the requested calculation.")))

(webgate-main)

;; -*- mode: Scheme; -*-
;;
;; This file is distributed with WebGate for CHICKEN.
;; Copyright (c) 2006-2010 by Felix L. Winkelmann.  All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above
;;    copyright notice, this list of conditions and the following
;;    disclaimer in the documentation and/or other materials provided
;;    with the distribution.
;;
;; 3. The name of the authors may not be used to endorse or promote
;;    products derived from this software without specific prior
;;    written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(declare (disable-interrupts))

(define error-output ##sys#standard-error)
(define standard-output ##sys#standard-output)
(define standard-input ##sys#standard-input)

(define (exception-handler ex)
  (thread-signal! (thread-specific ##sys#current-thread) ex)
  (continuation-drop #f) )

(define (with-limited-continuation thunk)
  (let* ((t (make-thread 
	     (lambda ()
	       (##sys#call-with-cthulhu
		(lambda () 
		  (##sys#call-with-values thunk continuation-drop) ) ) ) ) )
	 (state (##sys#slot t 5)) )
    (##sys#setislot state 0 '())
    (##sys#setslot state 1 standard-input)
    (##sys#setslot state 2 standard-output)
    (##sys#setslot state 3 error-output) 
    (##sys#setslot state 4 exception-handler)
    (thread-specific-set! t ##sys#current-thread)
    (thread-start! t)
    (thread-suspend! ##sys#current-thread)
    (##sys#setslot (##sys#slot t 5) 5 (##sys#slot state 5))
    (##sys#apply-values (##sys#slot t 2)) ) )

(define (continuation-drop . results)
  (##sys#setslot ##sys#current-thread 2 results)
  (thread-resume! (thread-specific ##sys#current-thread))
  (##sys#thread-kill! ##sys#current-thread 'dead) 
  (##sys#schedule) )

(define (continuation-suspend store)
  (##sys#apply-values
   (##sys#call-with-direct-continuation
    (lambda (k)
      (let ((o (open-output-string)))
	(serialize k o)
	(##sys#call-with-values 
	 (lambda () (store (get-output-string o)))
	 continuation-drop) ) ) ) ) )

(define (continuation-resume k . results)
  (##sys#direct-return (with-input-from-string k deserialize) results) )

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

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

;; -*- 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
................................................................................
  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)))
................................................................................
	   (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")
................................................................................
			       ,@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 "="))
................................................................................
	  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-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
................................................................................
  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)))
................................................................................
	   (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")
................................................................................
			       ,@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 "="))
................................................................................
	  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))

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

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

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

(define current-suspension-key
  (make-parameter
   (let ((ctx (create-context ALGO-SHA2)))
     (encrypt ctx (call-with-input-file "/proc/self/exe"
		    (cut read-string 8192 <>)))
     (encrypt ctx "")
     (let ((key (attribute/string ctx CTXINFO-HASHVALUE)))
       (destroy-object ctx)
       key))))



(define (wrap-suspension sk)
  (let ((evp (create-envelope FORMAT-CRYPTLIB)))
    (attribute-set! evp OPTION-ENCR-ALGO ALGO-AES)
    (attribute-set! evp OPTION-ENCR-HASH ALGO-SHA2)
    (attribute-set! evp OPTION-ENCR-MAC ALGO-HMAC-SHA2)
    (attribute-set! evp ENVINFO-INTEGRITY INTEGRITY-FULL)
    (attribute-set!/string evp ENVINFO-PASSWORD (current-suspension-key))
    (attribute-set! evp ENVINFO-DATASIZE (string-length sk))
    (let ((port (open-output-object evp #f)))
      (write-string sk #f port)
      (close-output-port port))
    (let* ((port (open-input-object evp #f #t))
	   (sk (read-string #f port)))
      (close-input-port port)
      (base64-encode sk))))









(define (unwrap-suspension sk)
  (let ((evp (create-envelope FORMAT-AUTO)))
    (condition-case
     (with-exception-handler
      (let ((abort (current-exception-handler)))
	(lambda (exn)











	  (if (and ((condition-predicate 'crypt) exn)
		   (eqv? ((condition-property-accessor 'crypt 'code #f) exn)
			 ENVELOPE-RESOURCE))
	      (attribute-set!/string
	       evp ENVINFO-PASSWORD (current-suspension-key))
	      (abort exn))))
      (lambda ()












	(let ((port (open-output-object evp #f)))
	  (write-string (base64-decode sk) #f port)
	  (close-output-port port))
	(and (eqv? (attribute evp ENVINFO-INTEGRITY) INTEGRITY-FULL)
	     (let* ((port (open-input-object evp #f #t))
		    (sk (read-string #f port)))
	       (close-input-port port)
	       sk))))
    ((exn crypt) #f)
    ((exn syntax) #f))))

(define-resource (suspended "suspended" sk parameters)
  (cond

   ((unwrap-suspension sk)
    => (cut continuation-resume <> parameters))
   (else
    (make-error-response
     404 "The requested suspended resource was not found on the server."))))

(define (send/suspend proc)
  (continuation-suspend
   (lambda (sk)


     (proc (resource-uri suspended (wrap-suspension sk))))))

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

(define (use-at-read-table . args)
  (current-read-table (nth-value 1 (make-at-reader+table args))))

;;; 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
................................................................................
	   ((#\+)
	    " ")
	   ((#\%) 
	    (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)

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









































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

(define (use-at-read-table . args)
  (current-read-table (nth-value 1 (make-at-reader+table args))))

;;; 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
................................................................................
	   ((#\+)
	    " ")
	   ((#\%) 
	    (string
	     (integer->char
	      (string->number (irregex-match-substring m 1) 16))))))))))

;;; Base64URI encoding

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define (base64-encode s)
  (let* ((n (string-length s))
	 (e (make-string (inexact->exact (ceiling (* 4/3 n))))))
    (do ((is 0 (fx+ is 3)) (ie 0 (fx+ ie 4))) ((fx>= is n) e)
      (let ((i (fxior
		(fxshl (char->integer (string-ref s is)) 16)
		(if (fx< (fx+ is 1) n)
		    (fxior
		     (fxshl (char->integer (string-ref s (fx+ is 1))) 8)
		     (if (fx< (fx+ is 2) n)
			 (char->integer (string-ref s (fx+ is 2)))
			 0))
		    0))))
	(string-set!
	 e ie
	 (string-ref base64-alphabet (fxand (fxshr i 18) #b111111)))
	(string-set!
	 e (fx+ ie 1)
	 (string-ref base64-alphabet (fxand (fxshr i 12) #b111111)))
	(when (fx< (fx+ is 1) n)
	  (string-set!
	   e (fx+ ie 2)
	   (string-ref base64-alphabet (fxand (fxshr i 6) #b111111)))
	  (when (fx< (fx+ is 2) n)
	    (string-set!
	     e (fx+ ie 3)
	     (string-ref base64-alphabet (fxand i #b111111)))))))))

(define base64-decode
  (let ((char->partial
	 (let ((tab
		(make-hash-table
		 eqv? eqv?-hash (string-length base64-alphabet))))
	   (do ((i 0 (fx+ i 1))) ((fx>= i (string-length base64-alphabet)))
	     (hash-table-set! tab (string-ref base64-alphabet i) i))
	   (lambda (chr)
	     (hash-table-ref
	      tab chr
	      (cut syntax-error 'base64-decode "illegal character" chr))))))
    (lambda (e)
      (let* ((n (string-length e))
	     (s (make-string (inexact->exact (floor (* 3/4 n))))))
	(do ((ie 0 (fx+ ie 4)) (is 0 (fx+ is 3))) ((fx>= ie n) s)
	  (let ((i (fxior
		    (fxshl
		     (char->partial (string-ref e ie)) 18)
		    (if (fx< (fx+ ie 1) n)
			(fxior
			 (fxshl
			  (char->partial (string-ref e (fx+ ie 1))) 12)
			 (if (fx< (fx+ ie 2) n)
			     (fxior
			      (fxshl
			       (char->partial (string-ref e (fx+ ie 2))) 6)
			      (if (fx< (fx+ ie 3) n)
				  (char->partial (string-ref e (fx+ ie 3)))
				  0))
			     0))
			0))))
	    (string-set!
	     s is (integer->char (fxand (fxshr i 16) #xff)))
	    (when (fx< (fx+ ie 2) n)
	      (string-set!
	       s (fx+ is 1) (integer->char (fxand (fxshr i 8) #xff)))
	      (when (fx< (fx+ ie 3) n)
		(string-set!
		 s (fx+ is 2) (integer->char (fxand i #xff)))))))))))

;;; HTML output

(define write-html
  (letrec ((tag-rules
	    (alist->hash-table
	     '((area . void)
	       (base . void)

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

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

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

  (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)
................................................................................
   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
   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 max-suspended-resources-load
   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; -*-
;;
;; 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
................................................................................
;; 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
 protobuf cryptlib)

(module suspension
  (with-limited-continuation 
   continuation-drop
   continuation-suspend
   continuation-resume) 
  (import
   scheme chicken
   srfi-18 ports (only protobuf-generic serialize deserialize))
  (include
   "suspension.scm"))

(module webgate-utils


  (write-netstring read-netstring
   make-at-reader make-at-read-table use-at-read-table
   uri-encode uri-decode
   base64-encode base64-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 message-text
   write-message
   max-request-size
   request-method-handler
   request-body-handler
   request-parameter-handler
   parameter-list-ref parameter-ref
   resource-context current-resource-context resource-context?
   resource-context-getenv resource-context-method resource-context-path
   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
   protobuf-generic suspension webgate-utils)
  (include
   "webgate-core.scm"))

(module webgate-suspend
  (current-suspension-key

   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-18 srfi-69
   extras suspension cryptlib webgate-utils webgate-core)
  (include
   "webgate-suspend.scm"))

(module webgate-cgi
  (cgi-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 message-text
   parameter-list-ref parameter-ref



   resource-context current-resource-context resource-context?
   resource-context-getenv resource-context-method resource-context-path
   response make-response response?
   collect-response make-html-response make-error-response
   response-status response-status-message
   resource-handler define-resource resource-uri



   send/suspend
   webgate-main)
  (import
   scheme chicken
   srfi-13 webgate-core webgate-suspend webgate-cgi webgate-scgi tcp)

(define (webgate-main #!optional (arguments (command-line-arguments)))
  (apply
   (lambda (#!key port (backlog 4) (host "localhost") (suspension-key #f))
     (cond
      (suspension-key => current-suspension-key))
     (if port




	 (scgi-main-loop handle-request (tcp-listen port backlog host))
	 (cgi-main-loop handle-request)))
   (map
    (lambda (arg)
      (if (string-prefix? "-" arg)
	  (string->keyword (substring/shared arg 1))
	  (or (string->number arg) arg)))
    arguments)))

)

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



(cond-expand
 (enable-static
  (compile -c -O2 -d1 "webgate.scm"
	   -unit webgate))
 (else
  ))

(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"

   ,@(cond-expand
      (enable-static
       '("webgate.o"))
      (else
       '()))
   "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")
   ,@(cond-expand
      (enable-static
       '((static "webgate.o")
	 (static-options "-luuid")))
      (else
       '()))))

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

(compile -s -O2 -d1 "at-expr.scm")

(cond-expand
 (enable-static
  (compile -c -O2 -d1 "webgate.scm"
	   -unit webgate))
 (else
  ))

(compile -s -O2 -d0 "webgate.import.scm")
(compile -s -O2 -d0 "suspension.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"
   "at-expr.so"
   ,@(cond-expand
      (enable-static
       '("webgate.o"))
      (else
       '()))
   "webgate.import.so"
   "suspension.import.so"
   "webgate-utils.import.so"
   "webgate-core.import.so"
   "webgate-suspend.import.so"
   "webgate-cgi.import.so"
   "webgate-scgi.import.so")
 `((version "2.0.0")
   ,@(cond-expand
      (enable-static
       '((static "webgate.o")))

      (else
       '()))))