;;;; cgi-handler.scm
;
; Copyright (c) 2007-2009, 2016, Peter Bex
; Copyright (c) 2000-2005, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of the author nor the names of its
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.
;
; CGI file handler
; See the spec at http://hoohoo.ncsa.uiuc.edu/cgi/interface.html
; Newer CGI spec: RFC 3875 at http://www.ietf.org/rfc/rfc3875

(module cgi-handler
  (cgi-handler cgi-handler* cgi-default-environment)

(import scheme)

(cond-expand
  (chicken-4
   (import chicken scheme)
   (use extras files posix irregex data-structures
        spiffy srfi-1 srfi-13 intarweb uri-common (prefix uri-generic generic:)))
  (chicken-5 (import (chicken base) (chicken irregex) (chicken string)
                     (chicken format) (chicken condition) (chicken io)
                     (chicken pathname) (chicken process) (chicken file)
                     srfi-1 srfi-13 spiffy intarweb uri-common
                     (prefix uri-generic generic:))
             
             (define file-read-access? file-readable?)
             (define file-execute-access? file-executable?)))

(include "cgi-common.scm")

(define (cgi-handler* #!optional interp)
  (lambda (fn) (cgi-handler fn interp)))

(cond-expand
  (chicken-4
   (define (alist->envlist alist)
     (map (lambda (entry)
            (conc (car entry) "=" (or (cdr entry) "")))
          alist)))
  (chicken-5
   (define (alist->envlist alist)
     (map (lambda (entry)
            (cons (->string (car entry)) (->string (or (cdr entry) ""))))
          alist))))

(define (cgi-build-env req fn)
  (let* ((server-env
          ;; We're not supposed to send SCRIPT_NAME to an Authorizer.
          `(("SCRIPT_NAME" . ,(current-file))
            ;; More stuff needed because PHP's CGI is broken
            ;; See http://bugs.php.net/28227
            ;; (yes, that's right; it's been broken since 2004)
            ("SCRIPT_FILENAME" . ,fn)))
         (header-env (create-header-env (request-headers req))))
    (append header-env (cgi-standard-server-env req)
            (cgi-default-environment) server-env)))

(define (copy-port/limit in out #!optional limit)
  (let ((bufsize 1024))
    (let loop ((data (read-string (min (or limit bufsize) bufsize) in)))
      (unless (or (eof-object? data) (string-null? data))
        (display data out)
        (when limit (set! limit (- limit (string-length data))))
        (loop (read-string (min (or limit bufsize) bufsize) in))))))

;; Read a port and discard all data
(define (discard-inport in)
  (let ((bufsize 1024))
    (let loop ((data (read-string bufsize in)))
      ;; In CHICKEN 5, read-string returns eof-object!
      (unless (or (eof-object? data) (string-null? data))
        (loop (read-string bufsize in))))))

(define (cgi-handler fn #!optional interp)
  (let* ((path (if (absolute-pathname? fn) fn (make-pathname (root-path) fn)))
         (req (current-request))
         (len (header-value 'content-length (request-headers req) 0))
	 (interp (or interp (make-pathname (root-path)
                                           (string-join (cdr (uri-path (request-uri req))) "/"))))
	 (env (alist->envlist (cgi-build-env req path))))
    ;; TODO: stderr should be linked to spiffy error log
    (if (file-execute-access? interp)
        ;; XXX The script should be called with the query args on the
        ;; commandline but only if those do not contain any unencoded '='
        ;; characters. Otherwise, it should pass no commandline arguments.
        ;; XXX Current working directory should be the dir with the script.
	(let-values (((i o pid) (process interp (list path) env)))
          (log-to (debug-log) "(cgi) started program ~a(~a) ..." interp path)
          (copy-port/limit (request-port (current-request)) o len)
          (close-output-port o)
          ;; TODO: Implement read timeout
          (let* ((script-headers (read-cgi-headers i))
                 (loc (header-value 'location script-headers))
                 (status (header-value 'status script-headers))
                 (code (cond
                        (status (car status))
                        (loc 302)
                        (else (response-code (current-response)))))
                 (reason (cond
                          (status (cdr status))
                          (loc "Found")
                          (else (response-reason (current-response)))))
                 ;; Drop Status "header" so we don't forward it to client
                 (script-headers (remove-header 'status script-headers)))
            (parameterize ((current-response
                            (update-response (current-response)
                                             headers:  (sanitize-headers
                                                        script-headers)
                                             code: code
                                             reason: reason)))
              (write-logged-response)
              (if (eq? 'HEAD (request-method (current-request)))
                  (discard-inport i)
                  (copy-port/limit i (response-port (current-response))))
              (close-input-port i))))
          (error (sprintf "Invalid interpreter: ~A\n" interp)))))

(define cgi-default-environment
  (make-parameter `(("GATEWAY_INTERFACE" . "CGI/1.1"))))
)