;; -*- 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.

;;; Message base type

(define-record-type message
  %make-message #t
  type headers
  body)

(define (make-message
	 body #!key
	 (type "application/octet-stream") (headers '()))
  (%make-message type headers body))

(define (write-message msg #!optional (port (current-output-port)))
  (let ((type (message-type msg))
	(body (message-body msg)))
    (when type
      (fprintf port "Content-type: ~a\r\n" type))
    (when body
      (fprintf port "Content-length: ~a\r\n" (string-length body)))
    (for-each
     (lambda (header)
       (call-with-values (cut car+cdr header)
	 (cut fprintf port "~a: ~a\r\n" <> <>)))
     (message-headers msg))
    (display "\r\n" port)
    (when body
      (display body port))))

;;; Request processing infrastructure

(define max-request-size
  (make-parameter #xffff))

(define-values (request-method-handler handled-request-methods)
  (let ((handlers (make-hash-table #:test string-ci=? #:hash string-ci-hash)))
    (values
     (case-lambda
       ((name)
	(hash-table-ref/default handlers name #f))
       ((name proc)
	(hash-table-set! handlers name proc)))
     (cut hash-table-keys handlers))))

(define request-body-handler
  (let ((handlers (make-hash-table #:test string-ci=? #:hash string-ci-hash)))
    (case-lambda
      ((name)
       (hash-table-ref/default handlers name #f))
      ((name proc)
       (hash-table-set! handlers name proc)))))

(define request-parameter-handler
  (let ((handler
	 (lambda (parameters key msg)
	   (hash-table-update!/default
	    parameters key (cut append! <> (list msg)) '()))))
    (case-lambda
     (()
      handler)
     ((proc)
      (set! handler proc)))))

;;; Response processing infrastructure

(define-record-type resource-context
  %make-resource-context #t
  getenv return)

(define (current-resource-context)
  (let ((ctx (thread-specific (current-thread))))
    (and (resource-context? ctx) ctx)))

(define status-table
  (alist->hash-table
   '((100 . "Continue")
     (101 . "Switching Protocols")
     (200 . "Ok")
     (201 . "Created")
     (202 . "Accepted")
     (203 . "Non-Authoritative Information")
     (204 . "No Content")
     (205 . "Reset Content")
     (206 . "Partial Content")
     (300 . "Multiple Choices")
     (301 . "Moved Permanently")
     (302 . "Found")
     (303 . "See Other")
     (304 . "Not Modified")
     (305 . "Use Proxy")
     (307 . "Temporary Redirect")
     (400 . "Bad Request")
     (401 . "Unauthorized")
     (402 . "Payment Required")
     (403 . "Forbidden")
     (404 . "Not Found")
     (405 . "Method Not Allowed")
     (406 . "Not Acceptable")
     (407 . "Proxy Authentication Required")
     (408 . "Request Timeout")
     (409 . "Conflict")
     (410 . "Gone")
     (411 . "Length Required")
     (412 . "Precondition Failed")
     (413 . "Request Entity Too Large")
     (414 . "Request-URI Too Long")
     (415 . "Unsupported Media Type")
     (416 . "Requested Range Not Satisfiable")
     (417 . "Expectation Failed")
     (500 . "Internal Server Error")
     (501 . "Not Implemented")
     (502 . "Bad Gateway")
     (503 . "Service Unavailable")
     (504 . "Gateway Timeout")
     (505 . "HTTP Version Not Supported"))
   #:test = #:hash number-hash))

(define-record-type (response message)
  %make-response #t
  status status-message)

(define (make-response
	 status body #!key
	 (type (and body "application/octet-stream"))
	 (headers '())
	 (status-message
	  (hash-table-ref/default status-table status "Unknown")))
  (%make-response
   type headers body
   status status-message))

(define (collect-response
	 status thunk #!key
	 (type "application/octet-stream")
	 (headers '())
	 (status-message
	  (hash-table-ref/default status-table status "Unknown")))
  (%make-response
   type headers (with-output-to-string thunk)
   status status-message))

(define (make-html-response
	 status html #!key
	 (status-message
	  (hash-table-ref/default status-table status "Unknown"))
	 (headers '()))
  (%make-response
   "text/html" headers (call-with-output-string (cut write-html html <>))
   status status-message))

(define (make-error-response
	 status message #!key
	 (status-message
	  (hash-table-ref/default status-table status "Unknown"))
	 (headers '()))
  (make-html-response
   status
   (let ((status-line (sprintf "~a ~a" status status-message)))
     `(html
       (head
	(meta ((name "robots") (content "noindex")))
	(title ,status-line))
       (body
	(h1 ,status-line)
	(p ,message))))
   #:status-message status-message
   #:headers headers))

(define (write-response rsp #!optional (port (current-output-port)))
  (fprintf
   port "Status: ~a ~a\r\n"
   (response-status rsp) (response-status-message rsp))
  (write-message rsp port))

(define resource-handler
  (let ((handlers (make-hash-table)))
    (case-lambda
      ((path)
       (let next ((handlers handlers) (args '()) (path path))
	 (if (pair? path)
	     (let-values (((step path) (car+cdr path)))
	       (cond
		((hash-table-ref/default handlers step #f)
		 => (cut next <> args path))
		((hash-table-ref/default handlers #f #f)
		 => (cut next <> (cons step args) path))
		(else
		 #f)))
	     (cond
	      ((hash-table-ref/default handlers #t #f)
	       => (lambda (proc)
		    (lambda (parameters)
		      (apply proc (reverse! (cons* parameters args))))))
	      (else
	       #f)))))
      ((path proc)
       (let next ((handlers handlers) (path path))
	 (if (pair? path)
	     (let-values (((step path) (car+cdr path)))
	       (hash-table-update!
		handlers step (cut next <> path) make-hash-table))
	     (hash-table-set! handlers #t proc))
	 handlers)
       (void)))))

(define-syntax define-resource
  (syntax-rules ()
    ((define-resource (name step/arg ... parameters)
       expr ...)
     (begin
       (define name
	 (let-syntax ((path
		       (ir-macro-transformer
			(lambda (stx inject id=?)
			  (let ((steps (cdr stx)))
			    `(list ,@(map
				      (lambda (step)
					(and (string? step) step))
				      steps))))))
		      (path-lambda
		       (ir-macro-transformer
			(lambda (stx inject id=?)
			  (let ((steps (cadr stx))
				(body (cddr stx)))
			    `(lambda ,(filter-map
				       (lambda (step)
					 (and (symbol? step) step))
				       steps)
			       ,@body))))))
	   (extend-procedure
	    (path-lambda (step/arg ... parameters)
	      expr ...)
	    (path step/arg ...))))
       (resource-handler (procedure-data name) name)))))

(define (resource-uri res . args)
  (uri-encode
   (call-with-output-string
    (lambda (port)
      (for-each
       (cut fprintf port "/~a" <>)
       (string-split
	(or ((resource-context-getenv (current-resource-context)) "SCRIPT_NAME")
	    "")
	"/"))
      (let next ((steps (procedure-data res)) (args args))
	(if (pair? steps)
	    (let-values (((step steps) (car+cdr steps)))
	      (if step
		  (begin
		    (fprintf port "/~a" step)
		    (next steps args))
		  (if (pair? args)
		      (let-values (((arg args) (car+cdr args)))
			(fprintf port "/~a" arg)
			(next steps args))
		      (error 'resource-uri "too few arguments"))))
	    (unless (null? args)
	      (error 'resource-uri "too many arguments" args))))))))

;;; Pre-installed default handlers (and directly related stuff)
	
(define (handle-query-parameters parameters query)
  (for-each
   (lambda (key+value)
     (let-optionals (map uri-decode (string-split key+value "="))
		    ((key #f) (value ""))
       (when key
	 ((request-parameter-handler)
	  parameters key
	  (make-message value #:type "text/plain")))))
   (string-split query "&;"))
  #f)

(request-body-handler "application/x-www-form-urlencoded"
  (lambda (parameters type size port)
    (handle-query-parameters parameters (read-string size port))))

(request-body-handler "multipart/form-data"
  (letrec ((boundary-rx
	    (irregex '(: bow "boundary=" ($ (+ (~ (" ;\n\r\t")))))))
	   (multipart-boundary
	    (lambda (s)
	      (cond
	       ((irregex-search boundary-rx s)
		=> (cut irregex-match-substring <> 1))
	       (else
		#f))))
	   (header-rx
	    (irregex '(: ($ (+ (~ #\:))) #\: (* space) ($ (*? any))
			 (or "\r\n" eos))))
	   (special+regular-headers
	    (lambda (s start end special)
	      (partition
	       (lambda (key+value)
		 (member (car key+value) special string-ci=?))
	       (irregex-fold
		header-rx
		(lambda (start m seed)
		  (cons (cons (irregex-match-substring m 1)
			      (irregex-match-substring m 2))
			seed))
		'() s
		(lambda (start seed)
		  (reverse! seed))
		start end))))
	   (name-rx
	    (irregex '(: bow "name=" #\" ($ (*? (~ #\"))) #\")))
	   (disposition-name
	    (lambda (s default)
	      (cond
	       ((irregex-search name-rx s)
		=> (cut irregex-match-substring <> 1))
	       (else
	        default))))
	   (handle-messages
	    (lambda (parameters name data boundary)
	      (let ((boundary-rx
		     (irregex `(: (or bos "\r\n") "--"
				  ,boundary
				  (? "--") "\r\n"))))
		(irregex-fold
		 boundary-rx
		 (lambda (start m skip?)
		   (and-let* (((not skip?))
			      (end
			       (irregex-match-start-index m))
			      (header-end
			       (string-contains data "\r\n\r\n" start end))
			      (body
			       (substring/shared data (+ header-end 4) end)))
		     (let-values (((specials headers)
				   (special+regular-headers
				    data start header-end
				    '("Content-type" "Content-length"))))
		       (let ((type
			      (alist-ref
			       "Content-type" specials string-ci=?
			       "text/plain"))
			     (name
			      (disposition-name
			       (alist-ref
				"Content-disposition" headers string-ci=?)
			       name)))
			 (when name
			   (cond
			    ((multipart-boundary type)
			     => (cut handle-messages parameters name body <>))
			    (else
			     ((request-parameter-handler)
			      parameters name
			      (make-message
			       body #:type type #:headers headers))))))))
		   #f)
		 #t data))
	      #f)))
    (lambda (parameters type size port)
      (cond
       ((multipart-boundary type)
	=> (cut handle-messages
		parameters #f (read-string size port) <>))
       (else
	(make-error-response
	 501 "The server doesn't know how to parse request parameters from the content type sent."))))))

(request-method-handler "GET"
  (lambda (parameters method getenv port)
    (handle-query-parameters parameters (or (getenv "QUERY_STRING") ""))))
  
(request-method-handler "POST"
  (lambda (parameters method getenv port)
    (or
     (handle-query-parameters parameters (or (getenv "QUERY_STRING") ""))
     (let ((type (or
		  (getenv "CONTENT_TYPE")
		  "application/octet-stream"))
	   (size (cond
		  ((getenv "CONTENT_LENGTH")
		   => string->number)
		  (else
		   #f))))
       (cond
	((not size)
	 (make-error-response
	  411 "The server refuses processing as no content length was sent with the request."))
	((cond ((max-request-size) => (cut > size <>)) (else #f))
	 (make-error-response
	  413 "The server refuses processing as the request's content length is too large."))
	((request-body-handler (substring/shared
				type 0 (or (string-index type #\;)
					   (string-length type))))
	 => (cut <> parameters type size port))
	(else
	 (make-error-response
	  501 "The server doesn't know how to parse request parameters from the content type sent.")))))))

;;; Central server routine

(define (handle-request getenv input-port output-port)
  (write-response
   (handle-exceptions
    exn (begin
	  (when (uncaught-exception? exn)
	    (set! exn (uncaught-exception-reason exn)))
	  (print-error-message
	   exn (current-error-port)
	   (sprintf "[~a] Request Handling Error" (current-seconds)))
	  (print-call-chain)
	  (make-error-response
	   500 "The server encountered an internal error handling the request."))
    (let ((parameters (make-hash-table))
	  (method (or (getenv "REQUEST_METHOD") "GET"))
	  (path (string-split (uri-decode (or (getenv "PATH_INFO") "")) "/")))
      (or
       (cond
	((request-method-handler method)
	 => (cut <> parameters method getenv input-port))
	(else
	 (make-error-response
	  405 "The access method used to request the document is not supported."
	  #:headers
	  (list
	   (cons "Allow" (string-join (handled-request-methods) ", "))))))
       (cond
	((resource-handler path)
	 => (lambda (proc)
	      (thread-join!
	       (thread-start!
		(make-thread
		 (lambda ()
		   (call-with-current-continuation
		    (lambda (return)
		      (thread-specific-set!
		       (current-thread)
		       (%make-resource-context getenv return))
		      (let ((rsp (proc parameters)))
			((resource-context-return (current-resource-context))
			 rsp))))))))))
	(else
	 (make-error-response
	  404 "The requested resource was not found by the server.")))
       (make-response 204 '()))))
   output-port))