;; -*- mode: Scheme; -*-
;; 
;; modified for chicken 5 and brmelect
;; Copyright (c) 2011-2013 by TMA.  All rights reserved.

;; https://chust.org/repos/chicken-webgate/file?name=webgate-utils.scm&ci=tip

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

;;; Compression

(declare (unit webgate-utils))

(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 base)
   ;(chicken foreign)
   (chicken io)
   (chicken format)
   (chicken fixnum)
   (chicken syntax)
   (chicken keyword)
   (chicken read-syntax)
   srfi-1 srfi-13 srfi-14 srfi-69
   ;(except data-structures compress) extras
   (chicken irregex))
  (import-for-syntax srfi-1)

#;(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))))
    (unless l
      (error
       'read-netstring
       "client side protocol error: malformed netstring (bad length)"))
    (unless (eq? (read-char port) #\:)
      (error
       'read-netstring
       "client side protocol error: malformed netstring (bad delimiter)"))
    (let ((s (read-string l port)))
      (unless (eq? (read-char port) #\,)
	(error
	 'read-netstring
	 "client side protocol error: malformed netstring (bad terminal)"))
      s)))

;;; @-expressions

(define (make-at-reader+table args)
  (letrec* ((command-char
	     (get-keyword #:command-char args (constantly #\@)))
	    (trim-whitespace?
	     (get-keyword #:trim-whitespace? args (constantly #t)))
	    (condense-whitespace?
	     (get-keyword #:condense-whitespace? args (constantly #t)))
	    (list-arguments?
	     (get-keyword #:list-arguments? args (constantly #f)))
	    (char-normal?
	     (cute char-set-contains?
		   (char-set-complement
		    (char-set command-char #\{ #\} #\return #\newline))
		   <>))
	    (char-group?
	     (cute char-set-contains?
		   (char-set #\[ #\{)
		   <>))
	    (skip-whitespace
	     (lambda (port)
	       (when (char-whitespace? (peek-char port))
		 (read-char port)
		 (skip-whitespace port))))
	    (read-whitespace
	     (if condense-whitespace?
		 (lambda (port)
		   (skip-whitespace port)
		   " ")
		 (cut read-token char-whitespace? <>)))
	    (read-datum
	     (lambda (port)
	       (parameterize ((current-read-table datum-read-table))
		 (read port))))
	    (read-at-exp
	     (lambda (port)
	       (skip-whitespace port)
	       (let ((char (peek-char port)))
		 (cond
		  ((eof-object? char)
		   (read-char port))
		  (else
		   (when (eqv? char command-char)
		     (read-char port))
		   (let* ((head (and (not (char-group? (peek-char port)))
				     (read-datum port)))
			  (args (and (eqv? (peek-char port) #\[)
				     (read-datum port)))
			  (body (and (eqv? (peek-char port) #\{)
				     (read-inside-at-exp 'skip port))))
		     (if (or args body)
			 (append!
			  (cond
			   (head => list)
			   (else '()))
			  (cond
			   ((and list-arguments? args) => list)
			   (else (or args '())))
			  (or body '()))
			 head)))))))
	    (read-inside-at-exp
	     (lambda (brace-mode port)
	       (append!
		(let ((head
		       (case brace-mode
			 ((none)
			  '())
			 ((skip)
			  (and (eqv? (peek-char port) #\{)
			       (begin (read-char port) '())))
			 (else
			  (and (eqv? (peek-char port) #\{)
			       (list (string (read-char port))))))))
		  (if head
		      (begin
			(when trim-whitespace? (skip-whitespace port))
			head)
		      (syntax-error
		       'read-inside-at-exp "expected @-expression body, found"
		       (peek-char port))))
		(let more ()
		  (let ((char (peek-char port)))
		    (cond
		     ((eqv? char #\{)
		      (case brace-mode
			((none)
			 (cons (string (read-char port)) (more)))
			(else
			 (append! (read-inside-at-exp 'keep port) (more)))))
		     ((eqv? char #\})
		      (case brace-mode
			((none)
			 (cons (string (read-char port)) (more)))
			((skip)
			 (read-char port)
			 '())
			(else
			 (list (string (read-char port))))))
		     ((eof-object? char)
		      (case brace-mode
			((none)
			 (read-char port)
			 '())
			(else
			 (syntax-error
			  'read-inside-at-exp "@-expression body not closed"))))
		     ((eqv? char command-char)
		      (cons (read-at-exp port) (more)))
		     ((char-whitespace? char)
		      (let* ((head (read-whitespace port))
			     (tail (more)))
			(if (or (pair? tail) (not trim-whitespace?))
			    (cons head tail)
			    tail)))
		     (else
		      (cons (read-token char-normal? port) (more)))))))))
	    (read-table
	     (get-keyword #:read-table args current-read-table))
	    (at-read-table
	     (parameterize ((current-read-table (copy-read-table read-table)))
	       (set-read-syntax! command-char read-at-exp)
	       (current-read-table)))
	    (datum-read-table
	     (let ((spec (get-keyword #:datum-read-table args (constantly #t))))
	       (cond
		((procedure? spec)
		 (spec at-read-table))
		(spec
		 at-read-table)
		(else
		 read-table)))))
    (values
     (if (get-keyword #:inside? args)
	 (lambda (#!optional (port (current-input-port)))
	   (read-inside-at-exp 'none port))
	 (lambda (#!optional (port (current-input-port)))
	   (read-at-exp port)))
     at-read-table)))

(define (make-at-reader . args)
  (nth-value 0 (make-at-reader+table args)))

(define (make-at-read-table . args)
  (nth-value 1 (make-at-reader+table args)))

(define (use-at-read-table . args)
  (current-read-table (nth-value 1 (make-at-reader+table args))))

;;; URI encoding

(define uri-encode
  (let ((problematic-rx (irregex '(~ (or alphanumeric "-._~")))))
    (lambda (s)
      (irregex-replace/all
       problematic-rx s
       (lambda (m)
	 (string-append
	  "%"
	  (string-pad
	   (number->string
	    (char->integer (string-ref (irregex-match-substring m) 0)) 16)
	   2 #\0)))))))

(define uri-decode
  (let ((escape-rx (irregex '(or #\+ (: #\% ($ (= 2 hex-digit)))))))
    (lambda (s)
      (irregex-replace/all
       escape-rx s
       (lambda (m)
	 (case (string-ref s (irregex-match-start-index m))
	   ((#\+)
	    " ")
	   ((#\%) 
	    (string
	     (integer->char
	      (string->number (irregex-match-substring m 1) 16))))))))))

;;; Base64URI encoding

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(define base64-alphabet/uri
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define (base64-encode s #!optional uri-safe?)
  (let* ((alphabet (if uri-safe? base64-alphabet/uri base64-alphabet))
	 (n (string-length s))
	 (e (make-string (inexact->exact (ceiling (* 4/3 n))))))
    (do ((is 0 (fx+ is 3)) (ie 0 (fx+ ie 4))) ((fx>= is n) e)
      (let ((i (fxior
		(fxshl (char->integer (string-ref s is)) 16)
		(if (fx< (fx+ is 1) n)
		    (fxior
		     (fxshl (char->integer (string-ref s (fx+ is 1))) 8)
		     (if (fx< (fx+ is 2) n)
			 (char->integer (string-ref s (fx+ is 2)))
			 0))
		    0))))
	(string-set!
	 e ie
	 (string-ref alphabet (fxand (fxshr i 18) #b111111)))
	(string-set!
	 e (fx+ ie 1)
	 (string-ref alphabet (fxand (fxshr i 12) #b111111)))
	(when (fx< (fx+ is 1) n)
	  (string-set!
	   e (fx+ ie 2)
	   (string-ref alphabet (fxand (fxshr i 6) #b111111)))
	  (when (fx< (fx+ is 2) n)
	    (string-set!
	     e (fx+ ie 3)
	     (string-ref alphabet (fxand i #b111111)))))))))

(define base64-decode
  (let ((alphabet-ref
	 (let* ((n (string-length base64-alphabet))
		(alphabet (make-hash-table eqv? eqv?-hash (fx+ n 2))))
	   (do ((i 0 (fx+ i 1))) ((fx>= i n))
	     (hash-table-set! alphabet (string-ref base64-alphabet i) i))
	   (do ((i (fx- n 2) (fx+ i 1))) ((fx>= i n))
	     (hash-table-set! alphabet (string-ref base64-alphabet/uri i) i))
	   (lambda (chr)
	     (hash-table-ref
	      alphabet chr
	      (cut syntax-error 'base64-decode "illegal character" chr))))))
    (lambda (e)
      (let* ((n (string-length e))
	     (s (make-string (inexact->exact (floor (* 3/4 n))))))
	(do ((ie 0 (fx+ ie 4)) (is 0 (fx+ is 3))) ((fx>= ie n) s)
	  (let ((i (fxior
		    (fxshl
		     (alphabet-ref (string-ref e ie)) 18)
		    (if (fx< (fx+ ie 1) n)
			(fxior
			 (fxshl
			  (alphabet-ref (string-ref e (fx+ ie 1))) 12)
			 (if (fx< (fx+ ie 2) n)
			     (fxior
			      (fxshl
			       (alphabet-ref (string-ref e (fx+ ie 2))) 6)
			      (if (fx< (fx+ ie 3) n)
				  (alphabet-ref (string-ref e (fx+ ie 3)))
				  0))
			     0))
			0))))
	    (string-set!
	     s is (integer->char (fxand (fxshr i 16) #xff)))
	    (when (fx< (fx+ ie 2) n)
	      (string-set!
	       s (fx+ is 1) (integer->char (fxand (fxshr i 8) #xff)))
	      (when (fx< (fx+ ie 3) n)
		(string-set!
		 s (fx+ is 2) (integer->char (fxand i #xff)))))))))))

;;; HTML output

(define write-html
  (letrec ((tag-rules
	    (alist->hash-table
	     '((area . void)
	       (base . void)
	       (br . void)
	       (col . void)
	       (command . void)
	       (embed . void)
	       (hr . void)
	       (img . void)
	       (input . void)
	       (keygen . void)
	       (link . void)
	       (meta . void)
	       (param . void)
	       (source . void)
	       (track . void)
	       (wbr . void)
	       (script . raw)
	       (style . raw))
	     #:test eq? #:hash eq?-hash))
	   (problematic-rx
	    (irregex '("\"&<>")))
	   (html-escape
	    (lambda (s)
	      (irregex-replace/all
	       problematic-rx s
	       (lambda (m)
		 (case (string-ref (irregex-match-substring m) 0)
		   ((#\") "&quot;")
		   ((#\&) "&amp;")
		   ((#\<) "&lt;")
		   ((#\>) "&gt;"))))))
	   (write-element
	    (lambda (elt port)
	      (unless (and (pair? elt) (symbol? (car elt)) (list? (cdr elt)))
		(error
		 'write-html "not a proper element"
		 elt))
	      (let-values (((tag attributes+contents)
			    (car+cdr elt)))
		(fprintf port "<~a" tag)
		(let-values (((rule)
			      (hash-table-ref/default tag-rules tag 'normal))
			     ((attributes contents)
			      (cond
			       ((null? attributes+contents)
				(values '() '()))
			       ((and (list? (car attributes+contents))
				     (every list? (car attributes+contents)))
				(car+cdr attributes+contents))
			       (else
				(values '() attributes+contents)))))
		  (for-each (cut write-attribute <> port) attributes)
		  (display #\> port)
		  (case rule
		    ((normal)
		     (for-each (cut write-content #t <> port) contents))
		    ((raw)
		     (for-each (cut write-content #f <> port) contents))
		    ((void)
		     (unless (null? contents)
		       (error
			'write-html "void elements cannot have contents"
			elt))))
		  (case rule
		    ((normal raw)
		     (fprintf port "</~a>" tag)))))))
	   (write-attribute
	    (lambda (attr port)
	      (unless (and (pair? attr) (symbol? (car attr)) (list? (cdr attr)))
		(error
		 'write-html "not a proper attribute"
		 attr))
	      (let-values (((key contents) (car+cdr attr)))
		(fprintf port " ~a=\"" key)
		(for-each (cut write-content #f <> port) contents)
		(display #\" port))))
	   (write-content
	    (lambda (allow-elements? v port)
	      (cond
	       ((symbol? v)
		(fprintf port "&~a;" v))
	       ((and (integer? v) (positive? v))
		(fprintf port "&#~a;" v))
	       ((string? v)
		(display (html-escape v) port))
	       (allow-elements?
		(write-element v port))
	       (else
		(error
		 'write-html "element not allowed in this context"
		 v))))))
    (lambda (html #!optional (port (current-output-port)))
      (display "<!DOCTYPE html>" port)
      (newline port)
      (write-element html port)
      (newline port))))

)
;;This page was generated in about 0.011s by Fossil 2.24 [8be0372c10] 2024-04-23 13:25:26