WebGate

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes to webgate-cgi.scm.

    24     24   ;; SOFTWARE.
    25     25   
    26     26   ;;; CGI server "loop"
    27     27   
    28     28   (define (cgi-main-loop handle-request)
    29     29     (handle-request 
    30     30      get-environment-variable
    31         -   (current-input-port) (current-output-port)))
           31  +   (current-input-port) (cute write-response <> (current-output-port))))

Changes to webgate-core.scm.

   442    442   	 => (cut <> parameters type size port))
   443    443   	(else
   444    444   	 (make-error-response
   445    445   	  501 "The server doesn't know how to parse request parameters from the content type sent.")))))))
   446    446   
   447    447   ;;; Central server routine
   448    448   
   449         -(define (handle-request getenv input-port output-port)
          449  +(define (handle-request getenv input-port write-response)
   450    450     (write-response
   451    451      (handle-exceptions
   452    452       exn (begin
   453    453   	  (when (uncaught-exception? exn)
   454    454   	    (set! exn (uncaught-exception-reason exn)))
   455    455   	  (print-error-message
   456    456   	   exn (current-error-port)
................................................................................
   478    478   	       (lambda ()
   479    479   		 (current-resource-context
   480    480   		  (%make-resource-context getenv method path))
   481    481   		 (proc parameters)))))
   482    482   	(else
   483    483   	 (make-error-response
   484    484   	  404 "The requested resource was not found by the server.")))
   485         -       (make-response 204 '()))))
   486         -   output-port))
          485  +       (make-response 204 '()))))))

Changes to webgate-scgi.scm.

    41     41   		       environment (irregex-match-substring m 1)
    42     42   		       (irregex-match-substring m 2))
    43     43   		      environment)
    44     44   		    (make-hash-table #:test string=? #:hash string-hash)
    45     45   		    (read-netstring input-port))))
    46     46   	      (handle-request
    47     47   	       (cut hash-table-ref/default environment <> #f)
    48         -	       input-port output-port))
           48  +	       input-port (cut write-response <> output-port)))
    49     49   	    (close-input-port input-port)
    50     50   	    (close-output-port output-port))))
    51     51   	(loop)))))

Added webgate-soup.scm.

            1  +;; -*- mode: Scheme; -*-
            2  +;;
            3  +;; This file is part of WebGate for CHICKEN.
            4  +;; Copyright (c) 2011-2013 by Thomas Chust.  All rights reserved.
            5  +;;
            6  +;; Permission is hereby granted, free of charge, to any person
            7  +;; obtaining a copy of this software and associated documentation
            8  +;; files (the Software), to deal in the Software without restriction,
            9  +;; including without limitation the rights to use, copy, modify,
           10  +;; merge, publish, distribute, sublicense, and/or sell copies of the
           11  +;; Software, and to permit persons to whom the Software is furnished
           12  +;; to do so, subject to the following conditions:
           13  +;; 
           14  +;; The above copyright notice and this permission notice shall be
           15  +;; included in all copies or substantial portions of the Software.
           16  +;; 
           17  +;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
           18  +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
           19  +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
           20  +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
           21  +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
           22  +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
           23  +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
           24  +;; SOFTWARE.
           25  +
           26  +(foreign-declare
           27  +  "#include <glib.h>\n"
           28  +  "#include <libsoup/soup.h>\n")
           29  +
           30  +(foreign-code
           31  +  "g_type_init();")
           32  +
           33  +(define soup-server-new
           34  +  (foreign-lambda* (c-pointer "SoupServer") ((unsigned-integer port))
           35  +    "C_return(soup_server_new(SOUP_SERVER_PORT, port, SOUP_SERVER_RAW_PATHS, TRUE, NULL));"))
           36  +
           37  +(define-external (webgate_soup_callback ((c-pointer "SoupServer") server)
           38  +					((c-pointer "SoupMessage") message)
           39  +					((const c-string) path)
           40  +					((c-pointer "GHashTable") query)
           41  +					((c-pointer "SoupClientContext") client)
           42  +					(c-pointer root)) void
           43  +  (((foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer)
           44  +    root)
           45  +   server message path))
           46  +
           47  +(define soup-server-add-handler
           48  +  (foreign-lambda* void (((nonnull-c-pointer "SoupServer") server)
           49  +			 (c-string path)
           50  +			 (scheme-object proc))
           51  +    "void *root = CHICKEN_new_gc_root();\n"
           52  +    "CHICKEN_gc_root_set(root, proc);\n"
           53  +    "soup_server_add_handler(server, path, webgate_soup_callback, root, CHICKEN_delete_gc_root);\n"))
           54  +
           55  +(define soup-server-run
           56  +  (foreign-safe-lambda void "soup_server_run" (nonnull-c-pointer "SoupServer")))
           57  +
           58  +(define soup-message-method
           59  +  (foreign-lambda* c-string (((nonnull-c-pointer "SoupMessage") message))
           60  +    "C_return(message->method);"))
           61  +
           62  +(define soup-message-query
           63  +  (foreign-lambda* c-string (((nonnull-c-pointer "SoupMessage") message))
           64  +    "C_return(soup_uri_get_query(soup_message_get_uri(message)));"))
           65  +
           66  +(define soup-request-header-ref
           67  +  (foreign-lambda* c-string (((nonnull-c-pointer "SoupMessage") message)
           68  +			     (nonnull-c-string name))
           69  +    "C_return(soup_message_headers_get_list(message->request_headers, name));"))
           70  +
           71  +(define soup-request-body
           72  +  (foreign-primitive scheme-object (((nonnull-c-pointer "SoupMessage") message))
           73  +    "SoupMessageBody *body = message->request_body;\n"
           74  +    "C_word *pool = C_alloc(C_SIZEOF_STRING(body->length));\n"
           75  +    "C_return(C_string(&pool, body->length, (char *)body->data));\n"))
           76  +
           77  +(define soup-response-header-add!
           78  +  (foreign-lambda* void (((nonnull-c-pointer "SoupMessage") message)
           79  +			 (nonnull-c-string name)
           80  +			 (c-string value))
           81  +    "soup_message_headers_append(message->response_headers, name, value);"))
           82  +
           83  +(define (soup-response-body-add! message data)
           84  +  ((foreign-lambda* void (((nonnull-c-pointer "SoupMessage") message)
           85  +			  (scheme-pointer data) (unsigned-integer length))
           86  +     "soup_message_body_append(message->response_body, SOUP_MEMORY_COPY, data, length);")
           87  +   message data (string-length data)))
           88  +
           89  +(define (soup-response-set! message rsp)
           90  +  ((foreign-lambda void "soup_message_set_status_full"
           91  +    (nonnull-c-pointer "SoupMessage") unsigned-integer nonnull-c-string)
           92  +   message (response-status rsp) (response-status-message rsp))
           93  +  (cond
           94  +   ((message-type rsp)
           95  +    => (cut soup-response-header-add! message "Content-Type" <>)))
           96  +  (for-each
           97  +    (lambda (header)
           98  +      (call-with-values (cut car+cdr header)
           99  +        (cut soup-response-header-add! message <> <>)))
          100  +    (message-headers rsp))
          101  +  (cond
          102  +   ((message-body rsp)
          103  +    => (cut soup-response-body-add! message <>))))
          104  +
          105  +;; soup server loop
          106  +
          107  +(define (soup-main-loop handle-request port)
          108  +  (let ((server (soup-server-new port)))
          109  +    (soup-server-add-handler
          110  +     server #f
          111  +     (lambda (server message path)
          112  +       (handle-request
          113  +        (lambda (name)
          114  +          (cond
          115  +           ((string=? name "REQUEST_METHOD")
          116  +            (soup-message-method message))
          117  +           ((string=? name "PATH_INFO")
          118  +            path)
          119  +           ((string=? name "QUERY_STRING")
          120  +            (soup-message-query message))
          121  +           (else
          122  +            (soup-request-header-ref message (string-translate name #\_ #\-)))))
          123  +        (open-input-string (soup-request-body message))
          124  +        (cut soup-response-set! message <>))))
          125  +    (soup-server-run server)))

Changes to webgate.scm.

    91     91      (only posix current-user-id current-group-id current-directory))
    92     92     (include
    93     93      "webgate-suspend.scm"))
    94     94   
    95     95   (module webgate-cgi
    96     96     (cgi-main-loop)
    97     97     (import
    98         -   scheme chicken)
           98  +   scheme chicken
           99  +   (only webgate-core write-response))
    99    100     (include
   100    101      "webgate-cgi.scm"))
   101    102   
   102    103   (module webgate-scgi
   103    104     (scgi-main-loop)
   104    105     (import
   105    106      scheme chicken
   106    107      srfi-13 srfi-18 srfi-69
   107         -   data-structures irregex webgate-utils tcp)
          108  +   data-structures irregex webgate-utils tcp
          109  +   (only webgate-core write-response))
   108    110     (include
   109    111      "webgate-scgi.scm"))
          112  +
          113  +(cond-expand
          114  +  (enable-soup
          115  +   (module webgate-soup
          116  +     (soup-main-loop)
          117  +     (import
          118  +      scheme chicken foreign
          119  +      srfi-1
          120  +      data-structures webgate-core)
          121  +     (include
          122  +      "webgate-soup.scm")))
          123  +  (else))
   110    124   
   111    125   (module webgate
   112    126     (webgate-main)
   113    127     (import
   114    128      scheme chicken
   115    129      srfi-13 webgate-cgi webgate-scgi tcp
   116    130      (only webgate-core
   117    131   	 handle-request)
   118    132      (only webgate-suspend
   119    133   	 current-suspension-key))
          134  +  (cond-expand
          135  +    (enable-soup
          136  +     (import webgate-soup))
          137  +    (else))
   120    138     (reexport
   121    139      (only webgate-core
   122    140   	 message make-message message?
   123    141   	 message-type message-headers message-body message-text
   124    142   	 parameter-list-ref parameter-ref
   125    143   	 resource-context current-resource-context resource-context?
   126    144   	 resource-context-getenv resource-context-method resource-context-path
   127    145   	 response make-response response?
   128    146   	 collect-response make-html-response make-error-response
   129    147   	 make-redirect-response
   130    148   	 response-status response-status-message
   131    149   	 define-resource resource-uri)
   132         -   (only webgate-suspend 
          150  +   (only webgate-suspend
   133    151   	 send/suspend))
   134    152   
   135    153   (define (webgate-main #!optional (arguments (command-line-arguments)))
   136    154     (apply
   137         -   (lambda (#!key port (backlog 4) (host "localhost") (suspension-key #f))
          155  +   (lambda (#!key (port #f) (backlog 4) (host "localhost") (suspension-key #f))
   138    156        (cond
   139    157         (suspension-key => current-suspension-key))
   140         -     (if port
   141         -	 (let ((ear (tcp-listen port backlog host)))
   142         -	   (dynamic-wind
   143         -	       void
   144         -	       (cut scgi-main-loop handle-request ear)
   145         -	       (cut tcp-close ear)))
   146         -	 (cgi-main-loop handle-request)))
          158  +     (cond
          159  +      ((and port (equal? host "http:*"))
          160  +       (cond-expand
          161  +        (enable-soup
          162  +         (soup-main-loop handle-request (string->number port)))
          163  +        (else
          164  +         (error 'webgate-main "HTTP support not enabled"))))
          165  +      (port
          166  +       (let ((ear (tcp-listen (string->number port) backlog host)))
          167  +         (dynamic-wind
          168  +	     void
          169  +	     (cut scgi-main-loop handle-request ear)
          170  +	     (cut tcp-close ear))))
          171  +      (else
          172  +       (cgi-main-loop handle-request))))
   147    173      (map
   148    174       (lambda (arg)
   149    175         (if (string-prefix? "-" arg)
   150    176   	  (string->keyword (substring/shared arg 1))
   151         -	  (or (string->number arg) arg)))
          177  +	  arg))
   152    178       arguments)))
   153    179   
   154    180   )

Changes to webgate.setup.

     1      1   ;; -*- mode: Scheme; -*-
     2         -(compile -s -O2 -d1 "webgate.scm"
     3         -	 -j webgate
     4         -	 -j suspension
     5         -	 -j webgate-utils
     6         -	 -j webgate-core
     7         -	 -j webgate-suspend
     8         -	 -j webgate-cgi
     9         -	 -j webgate-scgi)
    10         -
            2  +(compile -s -O2 -d1 "webgate.scm" -J)
    11      3   (compile -s -O2 -d1 "at-expr.scm")
    12      4   
    13      5   (cond-expand
    14      6    (enable-static
    15      7     (compile -c -O2 -d1 "webgate.scm"
    16      8   	   -unit webgate))
    17      9    (else
................................................................................
    20     12   (compile -s -O2 -d0 "webgate.import.scm")
    21     13   (compile -s -O2 -d0 "suspension.import.scm")
    22     14   (compile -s -O2 -d0 "webgate-utils.import.scm")
    23     15   (compile -s -O2 -d0 "webgate-core.import.scm")
    24     16   (compile -s -O2 -d0 "webgate-suspend.import.scm")
    25     17   (compile -s -O2 -d0 "webgate-cgi.import.scm")
    26     18   (compile -s -O2 -d0 "webgate-scgi.import.scm")
           19  +(cond-expand
           20  + (enable-soup
           21  +  (compile -s -O2 -d0 "webgate-soup.import.scm"))
           22  + (else
           23  +  ))
    27     24   
    28     25   (install-extension
    29     26    'webgate
    30     27    `("webgate.so"
    31     28      "at-expr.so"
    32     29      ,@(cond-expand
    33     30         (enable-static
................................................................................
    36     33          '()))
    37     34      "webgate.import.so"
    38     35      "suspension.import.so"
    39     36      "webgate-utils.import.so"
    40     37      "webgate-core.import.so"
    41     38      "webgate-suspend.import.so"
    42     39      "webgate-cgi.import.so"
    43         -   "webgate-scgi.import.so")
           40  +   "webgate-scgi.import.so"
           41  +   ,@(cond-expand
           42  +      (enable-soup
           43  +       '("webgate-soup.import.so"))
           44  +      (else
           45  +       '())))
    44     46    `((version "2.0.0")
    45     47      ,@(cond-expand
    46     48         (enable-static
    47     49          '((static "webgate.o")))
    48     50         (else
    49     51          '()))))