WebGate

Artifact d344d0a505267e7c73ed1539c19ca6e01652ad02:

• File webgate-soup.scm — part of check-in [11d7807ffd] at 2013-11-24 22:17:36 on branch trunk — Optional direct HTTP support using soup (user: murphy size: 4967)

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