WebGate

Artifact 19cdd101e2518fd561ffc1fbfed53a4ebc1101df:

• File webgate.scm — part of check-in [1c90f0c41c] at 2015-05-04 09:22:50 on branch trunk — Use TweetNaCl instead of Cryptlib for suspension encapsulation (user: murphy size: 5141)

;; -*- 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
 srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
 data-structures ports extras lolevel irregex tcp posix
 suspension tweetnacl)

(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
   make-redirect-response
   response-status response-status-message
   write-response
   resource-handler resource-uri
   (define-resource resource-handler extend-procedure procedure-data)
   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
   suspension webgate-utils)
  (include
   "webgate-core.scm"))

(module webgate-suspend
  (current-suspension-key
   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
   data-structures extras suspension tweetnacl webgate-utils webgate-core
   (only posix current-user-id current-group-id current-directory))
  (include
   "webgate-suspend.scm"))

(module webgate-cgi
  (cgi-main-loop)
  (import
   scheme chicken
   (only webgate-core write-response))
  (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
   (only webgate-core write-response))
  (include
   "webgate-scgi.scm"))

(cond-expand
  (enable-soup
   (module webgate-soup
     (soup-main-loop)
     (import
      scheme chicken foreign
      srfi-1
      data-structures webgate-core)
     (include
      "webgate-soup.scm")))
  (else))

(module webgate
  (webgate-main)
  (import
   scheme chicken
   srfi-13 webgate-cgi webgate-scgi tcp
   (only webgate-core
	 handle-request)
   (only webgate-suspend
	 current-suspension-key))
  (cond-expand
    (enable-soup
     (import webgate-soup))
    (else))
  (reexport
   (only webgate-core
	 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
	 make-redirect-response
	 response-status response-status-message
	 define-resource resource-uri)
   (only webgate-suspend
	 send/suspend))

(define (webgate-main #!optional (arguments (command-line-arguments)))
  (apply
   (lambda (#!key (port #f) (backlog 4) (host "localhost") (suspension-key #f))
     (cond
      (suspension-key => current-suspension-key))
     (cond
      ((and port (equal? host "http:*"))
       (cond-expand
        (enable-soup
         (soup-main-loop handle-request (string->number port)))
        (else
         (error 'webgate-main "HTTP support not enabled"))))
      (port
       (let ((ear (tcp-listen (string->number port) backlog host)))
         (dynamic-wind
	     void
	     (cut scgi-main-loop handle-request ear)
	     (cut tcp-close ear))))
      (else
       (cgi-main-loop handle-request))))
   (map
    (lambda (arg)
      (if (string-prefix? "-" arg)
	  (string->keyword (substring/shared arg 1))
	  arg))
    arguments)))

)