forked from brmlab/brmelect-github
2025 version
This commit is contained in:
parent
1d1468d87f
commit
ee4de955de
13 changed files with 2025 additions and 0 deletions
468
src/webgate-utils.scm
Normal file
468
src/webgate-utils.scm
Normal file
|
|
@ -0,0 +1,468 @@
|
|||
;; -*- 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue