;
;;  An implementation of the CGI protocol as described in RFC 3875
;;  "The Common Gateway Interface (CGI) 1.1".
;;
;;  Copyright 2013 Ivan Raikov.
;;
;;  Based in part on the Haskell Network.CGI library by Peter Thiemann
;;  and Bjorn Bringert, and the Moscow ML CGI library by Peter
;;  Sestoft.
;;


(module cgi-protocol

	(run-action decode-input
         request-inputs request-body
         input-value input-ct input-filename

         simple-input->string
         simple-input->charlist
         simple-input->number

         DocumentResponse
         LocalRedirResponse
         ClientRedirResponse
         ClientRedirDocResponse
         )

	(import scheme chicken)

	(require-extension data-structures srfi-1 utf8 utf8-srfi-14 matchable)

	(require-library extras)
	(import (only extras sprintf fprintf ))

	(require-extension byte-blob datatype typeclass input-classes cgi-environment)

	(require-library lexgen abnf)
        (import (only abnf <CoreABNF> CharLex->CoreABNF)
                (only lexgen <Token> <CharLex> Input->Token Token->CharLex))
        (require-library cgi-grammar)
        (import (only cgi-grammar <CGI> CoreABNF->CGI))
        


;; The value of an input parameter, and some metadata.
(define-record-type input 
  (Input value filename content-type)
  input?
  (value        input-value)
  (filename     input-filename)
  (content-type input-ct))


;; CGI request type  
(define-datatype request request?
  (Inputs           (lst (lambda (x) (every (lambda (x) (and (symbol? (car x)) (input? (cdr x)))) x))))
  (Body             (data byte-blob?))
  (InputsWithBody (lst (lambda (x) (every input? x)))
                  (data byte-blob?))
  )


(define (request-inputs r)
  (cases request r
        (Inputs (lst) lst)
        (Body (b) #f)
        (InputsWithBody (i b) i)))


(define (request-body r)
  (cases request r
         (Inputs (lst) #f)
         (Body (b) b)
         (InputsWithBody (i b) b)))



;; CGI response
(define-datatype response response?
  (DocumentResponse        (headers list?) (body list?))
  (LocalRedirResponse      (local-pathquery string?))
  (ClientRedirResponse     (fragment-URI string?)
			   (headers list?))
  (ClientRedirDocResponse  (fragment-URI string?)
			   (status status?)
			   (ct list?)
			   (headers list?)
			   (body list?)))


(define-datatype status status?
  (Status (num integer?) (msg list?)))


(define-record-printer (status x out)
  (cases status x
	 (Status (num msg)
		 (begin
		   (display num out)
		   (display " " out)
		   (display-fragments msg out)))))
		 
	 

;; Running CGI actions

(define crlf "\r\n")

(define default-content-type "text/html; charset=ISO-8859-1")


;; based on SRV:send-reply by Oleg Kiselyov
(define (display-fragments b out)
  (let loop ((fragments b) (result #f))
    (cond
      ((null? fragments) result)
      ((not (car fragments)) (loop (cdr fragments) result))
      ((null? (car fragments)) (loop (cdr fragments) result))
      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
      ((pair? (car fragments))
        (loop (cdr fragments) (loop (car fragments) result)))
      ((procedure? (car fragments))
        ((car fragments))
        (loop (cdr fragments) #t))
      (else
       (display (car fragments) out)
       (loop (cdr fragments) #t)))))


(define (display-headers hs out)
  (for-each (lambda (x) 
              (display-fragments (list (car x) #\: #\space (cdr x) crlf) out))
	    hs))


(define-record-printer (response r out)
  (cases response r
	 (DocumentResponse (rheaders rbody)
	   (let ((rheaders  (or (and (assoc 'Content-type rheaders) rheaders)
				(cons `(Content-type ,default-content-type) rheaders))))
	     (display-headers rheaders out)
	     (display crlf out)
	     (display-fragments rbody out)
             ))

	 (LocalRedirResponse (local-pathquery)
	     (display-headers `((Location ,local-pathquery)) out)
	     (display crlf out))

	 (ClientRedirResponse (fragment-URI headers)
	     (display-headers `((Location ,fragment-URI) ,@headers) out)
	     (display crlf out))

	 (ClientRedirDocResponse (fragment-URI status ct 
			          headers body)
	     (display-headers `((Location ,fragment-URI) 
				(Status ,(->string status))
				(Content-type ,(->string ct))
				,@headers)
			      out)
	     (display crlf out)
	     (display-fragments body out))
         ))



;; from SRFI-33, useful in splitting up the bit patterns used to
;; represent unicode values in utf8
(define-inline (extract-bit-field size position n)
  (bitwise-and (bitwise-not (arithmetic-shift -1 size))
               (arithmetic-shift n (- position))))


;; The following is borrowed from the utf8 library by Alex Shinn:
;; number of total bytes in a utf8 char given the 1st byte
(define utf8-start-byte-length
'#(
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 0x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 1x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 2x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 3x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 4x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 5x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 6x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 7x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 8x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 9x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; ax
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; bx
2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; cx
2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; dx
3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 ; ex
4 4 4 4 4 4 4 4 5 5 5 5 6 6 0 0 ; fx
))


;; The following two routines are based on the read-utf8-char routine
;; from the utf8 library by Alex Shinn:
(define (byte-blob-char-car b)
  (let ((b1 (fxand 255 (byte-blob-car b) )))
    (let ((len (vector-ref utf8-start-byte-length b1)))
      (if (<= len 1)
	  (integer->char b1)
          (let loop ((res (extract-bit-field (- 7 len) 0 b1))
		     (b (byte-blob-cdr b))
                     (i (- len 1)))
	    
            (if (zero? i)
		(integer->char res)
              (let ((b2 (byte-blob-car b)))
                (cond
		 ((not (= #b10 (extract-bit-field 2 6 b2)))
		  (error 'byte-blob-char-car "invalid utf8 sequence"))
		 (else
		  (loop (bitwise-ior (arithmetic-shift res 6)
				     (bitwise-and #b00111111 b2))
			(byte-blob-cdr b)
			(- i 1)))
		 ))
	      ))
	  )
      )))


(define (byte-blob-char-cdr x)
  (let ((b (fxand 255 (byte-blob-car x))))
    (let ((n (vector-ref utf8-start-byte-length b)))
      (if (fx= n 1)  (byte-blob-cdr x)
	  (byte-blob-drop x n))
	  )))


(define (byte-blob-char-trim pred x)
  (let ((c (byte-blob-char-car x)))
    (if (pred c) 
        (byte-blob-char-trim pred (byte-blob-char-cdr x))
        x)))


(define byte-blob-<Input>
  (make-<Input> byte-blob-empty? 
		byte-blob-char-car
		byte-blob-char-cdr))

(define byte-blob-<Token>
  (Input->Token byte-blob-<Input>))

(define byte-blob-<CharLex>
  (Token->CharLex byte-blob-<Token>))

(define byte-blob-<CoreABNF>
  (CharLex->CoreABNF byte-blob-<CharLex>))

(define byte-blob-<CGI>
  (CoreABNF->CGI byte-blob-<CoreABNF> ))

(import-instance (<CGI> byte-blob-<CGI> p.) )



;; Runs a CGI action and returns its response.
;; Actions are procedures of type request -> response.

(define (run-action action inp)
  (if (not (byte-blob? inp))
      (error 'run-action "invalid input" inp))
  (match-let (((inputs body)  (decode-input inp)))
    (let* ((rq   (cond ((null? inputs) (Body body))
                       ((not body) (Inputs inputs))
                       (else (InputsWithBody inputs body))))
	   (rs   (action rq)))
      (if (not (response? rs))
          (error 'run-action "invalid response received from action" rs))
      rs)))


;; Gets and decodes the input according to the request method and the
;; content-type.

(define (decode-input inp)
  (match-let (((inputs body)  (body-input inp)))
    (list (append (query-input) inputs) body)))


(define (body-input inp)
  (let ((method (request-method)))
    (cond ((and method
                (or (string=? method "POST")
                    (string=? method "GET")))
	   (let ((ctype (content-type)))
	     (decode-body ctype (read-input inp))))
	  (else (list (list) inp)))))


(define (positions s b)
  (let ((sb (if (string? s) (string->byte-blob s) s)))
    (byte-blob-find sb b)
    ))
        
(define (skip-line x) 
  (byte-blob-char-cdr (byte-blob-char-trim (lambda (c) (not (char=? c #\newline))) x)))


(define (split-part x)
  (p.part-headers
   (lambda (x) (list (car x) (skip-line (cadr x))))
   (lambda (x) (error 'split-part "MIME part headers parser error" x))
   `(() ,x)
   ))
  

(define (multipart-decode ps inp)
  (let ((boundary (alist-ref "boundary" ps string=?)))
    (if (not boundary) (list '() inp)
        (let* ((partb     (string->byte-blob (string-append "--" (car boundary) "\r\n")))
               (endb      (string->byte-blob (string-append "--" (car boundary) "--")))
               (blen      (byte-blob-length partb)))
          (match-let (((prefix contents) (positions partb inp)))
                     (let ((parts 
                            (let* ((pps1 (reverse (map car contents)))
                                   (pps2 (match-let
                                          (((last-part rest) (positions endb (car pps1))))
                                          (reverse (cons last-part (cdr pps1)))))
                                   )
                              (reverse
                               (filter-map 
                                (lambda (x) (let ((len (byte-blob-length x)))
                                              (byte-blob-span x blen (- len 2))))
                                pps2))
                              ))
                           )

                       (let ((content
                              (map (lambda (part) 
                                     (match-let (((headers content) (split-part part)))
                                                (let ((ctype (alist-ref 'Content-Type headers))
                                                      (fn (alist-ref 'Content-Disposition headers)))
                                                  (cons (string->symbol (car (alist-ref 'name fn)))
                                                        (if (not ctype)
                                                            (simple-input (map integer->char (byte-blob->list content)))
                                                            (Input content fn ctype)))
                                                  ))
                                                )
                                   parts)))
                         content
                         ))
                     ))
        ))
  )


;; Decodes a POST body.

(define (decode-body ctype inp)
  (match ctype
	 ((('type "multipart") ('subtype "form-data") . ps)
          (let ((content (multipart-decode ps inp)))
            (list content  #f)))
	 ((('type "application") ('subtype "x-www-form-urlencoded"))
	  (list (form-input inp) #f))
	 (else 
	  (list (list) inp))))


(define (read-input inp)
  (let ((len (content-length)))
    (if (not len)
        (error 'read-input "undefined content length") 
        (byte-blob-read inp len))))


(define default-input-type '( "text" "plain" ()))


;; Builds an 'Input' object for a simple value.
(define (simple-input v)  (Input v #f default-input-type))

(define (simple-input->string v)
  (match v
         (($ input val fn ct)
          (match ct (("text" _ _)  (list->string val))
                 (else #f)))
         (else #f)))
                

(define (simple-input->charlist v)
  (match v
         (($ input val fn ct)
          (match ct (("text" _ _)  val)
                 (else #f)))
         (else #f)))
                

(define (simple-input->number v)
  (match v
         (($ input val fn ct)
          (match ct (("text" "plain" _)  (string->number (list->string val)))
                 (else #f)))
         (else #f)))
                

;; Gets inputs from the query string.
(define (query-input)
  (let ((q (query-string)))
    (or (and q (form-input q)) '())))


(define-inline (octet-decode h1 h2)
  (string->number (list->string (list h1 h2)) 16))


(define (uri-char-decode cs)
  (let recur ((cs cs) (ax '()))
    (if (null? cs) (reverse ax)
        (let ((c (car cs)))
          (let ((c1.rest
                 (match c
                        (#\%
                         (let ((h1 (cadr cs)) (h2 (caddr cs)))
                           (cons
                            (integer->char (octet-decode h1 h2))
                            (cdddr cs))))
                        (#\+
                         (cons #\space (cdr cs)))
                        (else cs))))
            (let ((c1 (car c1.rest))
                  (rest (cdr c1.rest)))
              (recur rest (cons c1 ax)))
            ))
        ))
  )
                 
  
(define (form-urldecode char-list)
  (let recur ((char-list char-list)
              (ax '()))
    (if (null? char-list) ax
        (let-values (((kv rest)  
                      (span (lambda (c) (not (char=? c #\&))) char-list)))
          (let-values (((k v) (span (lambda (c) (not (char=? c #\=))) kv)))
            (recur (if (null? rest) rest (cdr rest))
                   (cons
                    (cons (string->symbol (list->string (uri-char-decode k)))
                          (if (null? v) v (uri-char-decode (cdr v))))
                    ax))
            ))
        ))
  )


;; Decodes application\x-www-form-urlencoded inputs.
(define (form-input qs)
  (map (lambda (nv) (cons (car nv) (simple-input (cdr nv))))
       (form-urldecode (map integer->char (byte-blob->list qs)))))





)