;; (C) 2003 Jörg F. Wittenberger see http://www.askemos.org

;; CGI

;; The CGI stuff is dead by default.  Do NOT casually export CGI
;; execution to the application level.  That would introduce a
;; unimaginable wide security hole!

;; Nevertheles CGI support is useful, many third party software comes
;; as CGI.  To enable CGI execution, create a function like this:

(define (test-cgi request) (run-cgi request *cgi-dir* "test-cgi"))

;; Than maintain an entry in the TrustedCode table.

;; Don't forget to set $trustedcode-oid in your configuration
;; accordingly.  Restart to re-read the TrustedCode table or call

;; (init-trustedcode $trustedcode-oid)

;; from the online debugger.

(define *cgi-dir* "/usr/lib/cgi-bin/")

(define (string-dot-right str)
  (let loop ((i (sub1 (string-length str))))
    (cond ((eqv? i -1) #f)
          ((eqv? (string-ref str i) #\.) i)
          (else (loop (sub1 i))))))



(define (splitwhite str start)
  (let ((start (let loop ((i start))
                 (if (or (eqv? i (string-length str))
                         (not (or (eqv? (string-ref str i) #\space)
                                  (eqv? (string-ref str i) #\tab))))
                        i (loop (add1 i))))))
    (let loop ((end (let loop ((i start))
                      (if (or (eqv? i (string-length str))
                              (eqv? (string-ref str i) #\space)
                              (eqv? (string-ref str i) #\tab))
                          i (loop (add1 i))))))
      (if (> end start)
          (cons (substring str start end) (splitwhite str end))
          '()))))

(define *mime.types* #f)

(define (load-mime.types! file)
  (set! *mime.types* (make-string-table))
  (call-with-input-file file
    (lambda (port)
      (do ((line (read-line port) (read-line port)))
          ((eof-object? line) #t)
        (if (and (> (string-length line) 1)
                 (not (eqv? (string-ref line 0) #\#)))
            (let ((p (splitwhite line 0)))
              (for-each (lambda (ext)
                          (table-insert! *mime.types* ext (car p)))
                        (cdr p))))))))

(define file-name->content-type
  (lambda (file)
      (let ((dot (string-dot-right file)))
        (and dot (table-lookup
                  *mime.types*
                  (substring file (add1 dot) (string-length file)))))))

(define (run-cgi request dir cgi)
  (let ((file (string-append dir cgi)))
    (if (file-execute-access? file)
        (run-child-process
         (lambda (out) (write-query-form (request 'body/parsed-xml) out))
         (lambda (in)
           (bind-exit
            (lambda (return)
              (let* (; (first (expect-object return not-eof-object? read-line in))
                     (reply (http-read-content return in #t)))
                ;; FIXME use 'first'
                (set-slot! reply 'http-status (or (get-slot reply 'status) 200))
                reply))))
         (list file)
         dir
         (let ((is-public (eq? (request 'dc-creator) (public-oid))))
           `(("SERVER_SOFTWARE" . "Askemos/BALL")
             ("SERVER_NAME" . , (or (request 'http-base-url) ""))
             ("GATEWAY_INTERFACE" . "CGI/1.1")
             ("SERVER_PROTOCOL" . "HTTP/1.1")
             ("SERVER_PORT" . "80") ; fake
             ("REQUEST_METHOD" . ,(or (request 'request-method) "POST"))
             ("HTTP_ACCEPT" . ,(or (request 'accept) ""))
             ("HTTP_USER_AGENT" . , (or (request 'http_user_agent) "mozilla"))
             ("PATH_INFO" . ,(http-format-read-location
                              (reverse (request 'destination))))
             ("PATH_TRANSLATED" . ,file)
             ("SCRIPT_NAME" . ,cgi)
             ("QUERY_STRING" . ,(call-with-output-string
                                 (lambda (port)
                                   (write-query-form
                                    (request 'body/parsed-xml) port))))
             ("REMOTE_HOST" . "localhost")
             ("REMOTE_ADDR" . "127.0.0.1")
             ("REMOTE_USER" . ,(or (and (not is-public)
                                        (entry-name (request 'dc-creator)))
                                   ""))
             ("AUTH_TYPE" . ,(if is-public "" "Basic"))
             ("CONTENT_TYPE" . ,(request 'content-type))
             ("CONTENT_LENGTH" . ,(number->string
                                   (string-length (request 'mind-body)))))))
        (make-message
         (property 'mind-body (file->string file))
         (property 'content-type (file-name->content-type file))))))