WebGate

Check-in [b520ce0466]
Login

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

Overview
Comment:Added BZip2 compression function wrappers
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:b520ce0466b8528b8fa1b756cefa17a5e119eb79
User & Date: murphy 2015-05-04 14:56:39
Context
2015-05-04
14:57
Compression for suspensions check-in: c4ebab70b3 user: murphy tags: trunk
14:56
Added BZip2 compression function wrappers check-in: b520ce0466 user: murphy tags: trunk
12:19
Improved listener configuration, HTTP_ prefix for soup header variables check-in: 8e0d0801c6 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to webgate-utils.scm.

19
20
21
22
23
24
25
































26
27
28
29
30
31
32
;; 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.

































;;; Netstrings

(define (write-netstring s #!optional (port (current-output-port)))
  (fprintf port "~a:~a," (string-length s) s))

(define (read-netstring #!optional (port (current-input-port)))
  (let ((l (string->number (read-token char-numeric? port))))







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
;; 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.

;;; Compression

(foreign-declare
 "#include <bzlib.h>")

(define (compress idata #!optional [level 9])
  (let* ((isize (string-length idata))
	 (odata (make-string (inexact->exact (round (+ 600 (* 1.01 isize)))))))
    (let-location ((osize unsigned-int (string-length odata)))
      (if ((foreign-lambda* bool ((scheme-pointer odata) ((c-pointer unsigned-int) osize)
				  (scheme-pointer idata) (unsigned-int isize) (int level))
	     "C_return(BZ2_bzBuffToBuffCompress(odata, osize, idata, isize, level, 0, 0) == BZ_OK);")
	   odata (location osize) idata isize level)
	  (substring odata 0 osize)
	  (error 'compress "Data compression error")))))

(define (decompress idata)
  (let ((isize (string-length idata)))
    (let retry ((odata (make-string (* 2 isize))))
      (let-location ((osize unsigned-int (string-length odata)))
	(case ((foreign-lambda* int ((scheme-pointer odata) ((c-pointer unsigned-int) osize)
				     (scheme-pointer idata) (unsigned-int isize))
		 "switch (BZ2_bzBuffToBuffDecompress(odata, osize, idata, isize, 0, 0)) {\n"
		 "case BZ_OK:          C_return(0);\n"
		 "case BZ_OUTBUFF_FULL: C_return(1);\n"
		 "default:             C_return(2);\n"
		 "}\n")
	       odata (location osize) idata isize)
	  ((0)  (substring odata 0 osize))
	  ((1)  (retry (make-string (* 2 osize))))
	  (else (error 'decompress "Data decompression error")))))))

;;; Netstrings

(define (write-netstring s #!optional (port (current-output-port)))
  (fprintf port "~a:~a," (string-length s) s))

(define (read-netstring #!optional (port (current-input-port)))
  (let ((l (string->number (read-token char-numeric? port))))

Changes to webgate.scm.

25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

(require-library
 srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
 data-structures ports extras lolevel irregex tcp posix
 suspension tweetnacl)

(module webgate-utils

  (write-netstring read-netstring
   make-at-reader make-at-read-table use-at-read-table
   uri-encode uri-decode
   base64-encode base64-decode
   write-html)
  (import
   scheme chicken foreign
   srfi-1 srfi-13 srfi-14 srfi-69
   data-structures extras irregex)
  (include
   "webgate-utils.scm"))

(module webgate-core
  (message make-message message?
   message-type message-headers message-body message-text
   write-message







>
|







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

(require-library
 srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
 data-structures ports extras lolevel irregex tcp posix
 suspension tweetnacl)

(module webgate-utils
  (compress decompress
   write-netstring read-netstring
   make-at-reader make-at-read-table use-at-read-table
   uri-encode uri-decode
   base64-encode base64-decode
   write-html)
  (import
   scheme chicken foreign
   srfi-1 srfi-13 srfi-14 srfi-69
   (except data-structures compress) extras irregex)
  (include
   "webgate-utils.scm"))

(module webgate-core
  (message make-message message?
   message-type message-headers message-body message-text
   write-message

Changes to webgate.setup.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

(cond-expand
 ((and webgate-internal-suspension enable-static)
  (compile -c -O2 -d1 "suspension.scm" -unit suspension))
 (else
  ))

(compile -s -O2 -d1 "webgate.scm" -J)
(compile -s -O2 -d1 "at-expr.scm")

(cond-expand
 (enable-static
  (compile -c -O2 -d1 "webgate.scm" -unit webgate))
 (else
  ))







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

(cond-expand
 ((and webgate-internal-suspension enable-static)
  (compile -c -O2 -d1 "suspension.scm" -unit suspension))
 (else
  ))

(compile -s -O2 -d1 "webgate.scm" -lbz2 -J)
(compile -s -O2 -d1 "at-expr.scm")

(cond-expand
 (enable-static
  (compile -c -O2 -d1 "webgate.scm" -unit webgate))
 (else
  ))