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