WebGate

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

(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

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