WebGate

Check-in [11d7807ffd]
Login
Home Timeline Branches Tags Tickets Wiki

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

Overview
Comment:Optional direct HTTP support using soup
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 11d7807ffd7ed1e3edba62ae175f3115e94caa17
User & Date: murphy 2013-11-24 22:17:36.403
Context
2015-05-04
08:03
Use letrec* in make-at-reader+table to ensure correct sequencing of operations check-in: 01fdd8217d user: murphy tags: trunk
2013-11-24
22:17
Optional direct HTTP support using soup check-in: 11d7807ffd user: murphy tags: trunk
2013-06-02
15:52
Removed serialization context customization in the wrong place check-in: c1e1794f45 user: murphy tags: trunk
Changes
Side-by-Side Diff Ignore Whitespace Patch
Changes to webgate-cgi.scm.
︙
24
25
26
27
28
29
30
31


24
25
26
27
28
29
30

31








-
+

;; SOFTWARE.

;;; CGI server "loop"

(define (cgi-main-loop handle-request)
  (handle-request 
   get-environment-variable
   (current-input-port) (current-output-port)))
   (current-input-port) (cute write-response <> (current-output-port))))
Changes to webgate-core.scm.
︙
442
443
444
445
446
447
448
449

450
451
452
453
454
455
456

442
443
444
445
446
447
448

449
450
451
452
453
454
455
456








-
+








	 => (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 output-port)
(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)
︙
478
479
480
481
482
483
484
485

486

478
479
480
481
482
483
484

485









-
+
-

	       (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 '()))))
       (make-response 204 '()))))))
   output-port))
Changes to webgate-scgi.scm.
︙
41
42
43
44
45
46
47
48

49
50
51

41
42
43
44
45
46
47

48
49
50
51








-
+




		       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 output-port))
	       input-port (cut write-response <> output-port)))
	    (close-input-port input-port)
	    (close-output-port output-port))))
	(loop)))))
Added webgate-soup.scm. 






























































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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






Changes to webgate.scm.






︙


91
92
93
94
95
96
97
98


99
100
101
102
103
104
105
106
107


108
109












110
111
112
113
114
115
116
117
118
119




120
121
122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137

138
139







140
141
142
143
144
145
146








147
148
149
150
151

152
153
154

91
92
93
94
95
96
97

98
99
100
101
102
103
104
105
106
107

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

150
151
152
153
154

155
156
157
158
159
160
161
162
163
164







165
166
167
168
169
170
171
172
173
174
175
176

177
178
179
180








-
+
+








-
+
+


+
+
+
+
+
+
+
+
+
+
+
+










+
+
+
+












-
+




-
+


+
+
+
+
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+




-
+




   (only posix current-user-id current-group-id current-directory))
  (include
   "webgate-suspend.scm"))

(module webgate-cgi
  (cgi-main-loop)
  (import
   scheme chicken)
   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)
   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 
   (only webgate-suspend
	 send/suspend))

(define (webgate-main #!optional (arguments (command-line-arguments)))
  (apply
   (lambda (#!key port (backlog 4) (host "localhost") (suspension-key #f))
   (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"))))
     (if port
	 (let ((ear (tcp-listen port backlog host)))
	   (dynamic-wind
	       void
	       (cut scgi-main-loop handle-request ear)
	       (cut tcp-close ear)))
	 (cgi-main-loop handle-request)))
      (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))
	  (or (string->number arg) arg)))
	  arg))
    arguments)))

)






Changes to webgate.setup.





1
2

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26





27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43






44
45
46
47
48
49

1

2








3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

40
41
42
43
44
45
46
47
48
49
50
51


-
+
-
-
-
-
-
-
-
-
















+
+
+
+
+
















-
+
+
+
+
+
+







;; -*- mode: Scheme; -*-
(compile -s -O2 -d1 "webgate.scm"
(compile -s -O2 -d1 "webgate.scm" -J)
	 -j webgate
	 -j suspension
	 -j webgate-utils
	 -j webgate-core
	 -j webgate-suspend
	 -j webgate-cgi
	 -j webgate-scgi)

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













This page was generated in about
0.009s by
Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32