forked from brmlab/brmelect-github
468 lines
14 KiB
Scheme
468 lines
14 KiB
Scheme
;; -*- 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)
|
|
((#\") """)
|
|
((#\&) "&")
|
|
((#\<) "<")
|
|
((#\>) ">"))))))
|
|
(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
|