;; -*- mode: Scheme; -*-
;;
;; 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.
;;; 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))))