WebGate

  "#include <glib.h>\n"
  "#include <libsoup/soup.h>\n")

(foreign-code
  "g_type_init();")

(define soup-server-new
  (foreign-lambda* (c-pointer "SoupServer") ((c-string host) (unsigned-integer port))
    "SoupAddress *address;\n"
    "if (host) {\n"
    "  address = soup_address_new(host, port);\n"
    "  if (soup_address_resolve_sync(address, NULL) != SOUP_STATUS_OK) C_return(NULL);\n"
    "} else {\n"
    "  address = soup_address_new_any(SOUP_ADDRESS_FAMILY_IPV4, port);"
    "}\n"
    "SoupServer *server = soup_server_new("
    "  SOUP_SERVER_INTERFACE, address,"
    "  SOUP_SERVER_RAW_PATHS, TRUE,"
    "  NULL"
    ");\n"
    "g_object_unref(address);\n"
    "C_return(server);"))

(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

    (message-headers rsp))
  (cond
   ((message-body rsp)
    => (cut soup-response-body-add! message <>))))

;; soup server loop

(define (soup-main-loop handle-request port #!optional host)
  (let ((server (soup-server-new host port)))
    (unless server
      (error 'soup-main-loop "Failed to create server" host port))
    (soup-server-add-handler
     server #f
     (lambda (server client message path)
       (handle-request
        (lambda (name)
          (cond
           ((string-prefix? "HTTP_" name)
            (soup-request-header-ref message (string-translate (substring/shared name 5) #\_ #\-)))
           ((string=? name "REQUEST_METHOD")
            (soup-message-method message))
           ((string=? name "PATH_INFO")
            path)
           ((string=? name "QUERY_STRING")
            (soup-message-query message))
	   ((or (string=? name "REMOTE_ADDR") (string=? name "REMOTE_HOST"))
	    (soup-client-address client))
	   ((string=? name "REMOTE_PORT")
	    (cond ((soup-client-port client) => number->string) (else #f)))
	   (else
	    #f)))
        (open-input-string (soup-request-body message))
        (cut soup-response-set! message <>))))
    (soup-server-run server)))

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

(module webgate
  (webgate-main)
  (import
   scheme chicken
   srfi-13 irregex webgate-cgi webgate-scgi tcp
   (only webgate-core
	 handle-request)
   (only webgate-suspend
	 current-suspension-key))
  (cond-expand
    (enable-soup
     (import webgate-soup))

	 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 (listen #f) (backlog 4) (suspension-key #f))
     (cond
      (suspension-key => current-suspension-key))
     (if listen
	 (let ((m (irregex-match
		   '(: (? ($ (+ (~ (":!")))) (":!")) (? ($ (+ (~ (":!")))) (":!")) ($ (+ num)))
		   listen)))
	   (if m
	       (let* ((port
		       (string->number (irregex-match-substring m 3)))
		      (host
		       (cond
			((irregex-match-substring m 2)
			 => (lambda (host) (if (string=? host "*") #f host)))
			(else
			 "localhost")))
		      (protocol
		       (cond
			((irregex-match-substring m 1)
			 => string->symbol)
			(else
			 'scgi))))
		 (case protocol
		   ((scgi)
		    (let ((ear (tcp-listen port backlog host)))
		      (dynamic-wind
			  void
			  (cut scgi-main-loop handle-request ear)
			  (cut tcp-close ear))))
		   ((http)
		    (cond-expand
		     (enable-soup
		      (soup-main-loop handle-request port host))
		     (else
		      (error 'webgate-main "HTTP support not enabled"))))
		   (else
		    (error 'webgate-main "Unknown protocol" protocol))))
	       (error 'webgate-main "Bad listener specification" listen)))
	 (cgi-main-loop handle-request)))
   (map
    (lambda (arg)
      (if (string-prefix? "-" arg)
	  (string->keyword (substring/shared arg 1))
	  arg))
    arguments)))

)