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