;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate for CHICKEN.
;; Copyright (c) 2011 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.

;;; UUIDs

(foreign-declare "#include <uuid/uuid.h>")

(define-foreign-type uuid-generator
  (function void ("uuid_t")))

(define (make-uuid #!optional mode)
  (let ((buf (make-string 36)))
    ((foreign-lambda* void ((uuid-generator generate)
			    (nonnull-scheme-pointer buf))
       "uuid_t uuid;"
       "generate(uuid);"
       "uuid_unparse_lower(uuid, buf);")
     (case mode
       ((random)
	(foreign-value "uuid_generate_random" uuid-generator))
       ((time)
	(foreign-value "uuid_generate_time" uuid-generator))
       (else
	(foreign-value "uuid_generate" uuid-generator)))
     buf)
    buf))

(define (uuid? v)
  (and (string? v)
       ((foreign-lambda* bool ((nonnull-c-string buf))
	  "uuid_t uuid;"
	  "C_return(uuid_parse(buf, uuid) == 0);")
	v)))

(define (uuid-time uuid)
  ((foreign-lambda* double ((nonnull-c-string buf))
     "uuid_t uuid;"
     "struct timeval time;"
     "if (uuid_parse(buf, uuid) != 0) C_return(nan(\"bad uuid\"));"
     "uuid_time(uuid, &time);"
     "C_return(((double)time.tv_sec) + ((double)time.tv_usec) / 1.0e6);")
   uuid))

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

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