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