WebGate

;; SOFTWARE.

;;; CGI server "loop"

(define (cgi-main-loop handle-request)
  (handle-request 
   get-environment-variable
   (current-input-port) (cute write-response <> (current-output-port))))

	 => (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 write-response)
  (write-response
   (handle-exceptions
    exn (begin
	  (when (uncaught-exception? exn)
	    (set! exn (uncaught-exception-reason exn)))
	  (print-error-message
	   exn (current-error-port)

	       (lambda ()
		 (current-resource-context
		  (%make-resource-context getenv method path))
		 (proc parameters)))))
	(else
	 (make-error-response
	  404 "The requested resource was not found by the server.")))
       (make-response 204 '()))))))

		       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 (cut write-response <> 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-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.

(foreign-declare
  "#include <glib.h>\n"
  "#include <libsoup/soup.h>\n")

(foreign-code
  "g_type_init();")

(define soup-server-new
  (foreign-lambda* (c-pointer "SoupServer") ((unsigned-integer port))
    "C_return(soup_server_new(SOUP_SERVER_PORT, port, SOUP_SERVER_RAW_PATHS, TRUE, NULL));"))

(define-external (webgate_soup_callback ((c-pointer "SoupServer") server)
					((c-pointer "SoupMessage") message)
					((const c-string) path)
					((c-pointer "GHashTable") query)
					((c-pointer "SoupClientContext") client)
					(c-pointer root)) void
  (((foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer)
    root)
   server message path))

(define soup-server-add-handler
  (foreign-lambda* void (((nonnull-c-pointer "SoupServer") server)
			 (c-string path)
			 (scheme-object proc))
    "void *root = CHICKEN_new_gc_root();\n"
    "CHICKEN_gc_root_set(root, proc);\n"
    "soup_server_add_handler(server, path, webgate_soup_callback, root, CHICKEN_delete_gc_root);\n"))

(define soup-server-run
  (foreign-safe-lambda void "soup_server_run" (nonnull-c-pointer "SoupServer")))

(define soup-message-method
  (foreign-lambda* c-string (((nonnull-c-pointer "SoupMessage") message))
    "C_return(message->method);"))

(define soup-message-query
  (foreign-lambda* c-string (((nonnull-c-pointer "SoupMessage") message))
    "C_return(soup_uri_get_query(soup_message_get_uri(message)));"))

(define soup-request-header-ref
  (foreign-lambda* c-string (((nonnull-c-pointer "SoupMessage") message)
			     (nonnull-c-string name))
    "C_return(soup_message_headers_get_list(message->request_headers, name));"))

(define soup-request-body
  (foreign-primitive scheme-object (((nonnull-c-pointer "SoupMessage") message))
    "SoupMessageBody *body = message->request_body;\n"
    "C_word *pool = C_alloc(C_SIZEOF_STRING(body->length));\n"
    "C_return(C_string(&pool, body->length, (char *)body->data));\n"))

(define soup-response-header-add!
  (foreign-lambda* void (((nonnull-c-pointer "SoupMessage") message)
			 (nonnull-c-string name)
			 (c-string value))
    "soup_message_headers_append(message->response_headers, name, value);"))

(define (soup-response-body-add! message data)
  ((foreign-lambda* void (((nonnull-c-pointer "SoupMessage") message)
			  (scheme-pointer data) (unsigned-integer length))
     "soup_message_body_append(message->response_body, SOUP_MEMORY_COPY, data, length);")
   message data (string-length data)))

(define (soup-response-set! message rsp)
  ((foreign-lambda void "soup_message_set_status_full"
    (nonnull-c-pointer "SoupMessage") unsigned-integer nonnull-c-string)
   message (response-status rsp) (response-status-message rsp))
  (cond
   ((message-type rsp)
    => (cut soup-response-header-add! message "Content-Type" <>)))
  (for-each
    (lambda (header)
      (call-with-values (cut car+cdr header)
        (cut soup-response-header-add! message <> <>)))
    (message-headers rsp))
  (cond
   ((message-body rsp)
    => (cut soup-response-body-add! message <>))))

;; soup server loop

(define (soup-main-loop handle-request port)
  (let ((server (soup-server-new port)))
    (soup-server-add-handler
     server #f
     (lambda (server message path)
       (handle-request
        (lambda (name)
          (cond
           ((string=? name "REQUEST_METHOD")
            (soup-message-method message))
           ((string=? name "PATH_INFO")
            path)
           ((string=? name "QUERY_STRING")
            (soup-message-query message))
           (else
            (soup-request-header-ref message (string-translate name #\_ #\-)))))
        (open-input-string (soup-request-body message))
        (cut soup-response-set! message <>))))
    (soup-server-run server)))

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

)

;; -*- mode: Scheme; -*-
(compile -s -O2 -d1 "webgate.scm" -J)








(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")
(cond-expand
 (enable-soup
  (compile -s -O2 -d0 "webgate-soup.import.scm"))
 (else
  ))

(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"
   ,@(cond-expand
      (enable-soup
       '("webgate-soup.import.so"))
      (else
       '())))
 `((version "2.0.0")
   ,@(cond-expand
      (enable-static
       '((static "webgate.o")))
      (else
       '()))))