;-*- Mode: Lisp; Package: acgi -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; acgi.lisp - version 2.0, May 17, 2002.
;; Streams for ACGI Apple Event communication between web servers and Mac CGIs.
;; <http://www.in-progress.com/src/acgi.lisp>
;; 
;; Copyright (C) 1997-2002 Terje Norderhaug and Media Design in*Progress.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License version 2 as published by the Free Software Foundation.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License version 2 for details.
;; 
;; The GNU Library General Public License is available on the web
;; from <http://www.gnu.org/copyleft/lgpl.html> or by writing to the
;; Free Software Foundation, Inc., 59 temple Place - Suite 330,
;; Boston, MA 02111-1307, USA. 
;;
;; Note that this is a different license from the more restrictive GNU GPL license.
;; If this license by any reason doesn't suit your needs, contact
;; the copyright holder of this library by sending an email to Terje Norderhaug 
;; at <terje@in-progress.com>. Please submit modifications of
;; the library to the same address. Any submitted modifications will 
;; automatically fall under the terms of this license unless otherwise specified.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VERSION HISTORY
;;
;; 2002-May-17 TN Version 2.0 released.
;; 2002-May-17 TN FIFO queue uses cheap consing.
;; 2002-May-02 TN Used in Interaction 4.0.
;; 2002-Apr-17 TN Uses process-poll to get acgi events from queue.
;; 2002-Apr-16 TN New suspend-ae function eliminates #_AESetTheCurrentEvent as it seem to cause crashes.
;;                  Resume-event renamed to resume-ae and uses unwind-protect to ensure aedesc is freed even on error. 
;;                  acgi-enqueue no longer calls #_AESetTheCurrentEvent when suspending events as it caused trouble.
;;                  Rearranged stream-close on acgi-server, uses without-interrupts and unwind-protect. 
;;                  ACGI connections counter and maximum.
;; 2002-Mar-27 TN send-partial signals acgi-server-peer-closed.
;;                  send-partial no longer has a filterproc in send-event.
;;                  send-partial executes without interrupts.
;; 2002-Mar-26 TN IO-BUFFER-EOFP sets content-length if necessarry.
;; 2002-Mar-26 TN Read HTTP Data queues the reply handler instead of waiting for response.
;; 2002-Mar-26 TN enable-cgi no longer sets *event-mask*
;; 2002-Mar-26 TN Substituted process-wait "Poll acgi data" with a loop.
;; 2002-Mar-26 TN Eliminated define-cgi-handler macro and cgi-handler, superseded by application-acgi-handler method.
;; 2002-Mar-26 TN ACGI handler returns an HTTP 503 response until CGI is enabled.
;; 2002-Mar-26 TN default handler now queues event rather than pass an empty response.
;; 2002-Mar-26 TN If there are no event/reply initarg to acgi server stream, it get next acgi event from queue.
;; 2002-Mar-26 TN New next-acgi function returns next acgi from queue when it becomes available.
;; 2002-Mar-14 TN Stream-close for acgi-server no longer do %free-aedesc on the event and reply apple event descriptors.
;;                New acgi-enqueue and call-next-acgi function automatically covers aedesc copy/suspend/resume/free.
;; 2002-Mar-08 TN Bypass MCL AppleEvent handling with new acgi-ae-handler, so that ACGI events are handled on interrupt.
;;                Mac-file-namestring replaces file-namestring to determine process name in cgi-input-stream.
;; 2001-Oct-01 TN generate-id function is about ten times faster and avoids creating bignums.
;; 2001-Mar-19 TN Fixed get-header-value so it doesn't fail if full-request is missing.
;; 2001-Jan-15 TN separate the stream-suspend functionality into a suspend-stream-mixin class.
;; 2001-Jan-15 TN stream-close frees the event and reply descriptors.
;; 2001-Jan-15 TN Replace stream-closed in the acgi-server class with the streams direction slot set to :close.
;; 2001-Jan-15 TN *allow-partial-responses* automatically set to NIL if event indicates no support for partial responses.
;; 2001-Jan-15 TN New conditions: acgi-response-too-large and acgi-server-peer-closed.
;; 2001-Jan-15 TN resume-event no longer frees descriptor, renamed to resume-event.
;; 2001-Jan-15 TN io-buffer-force-output reports error if responses goes beyond appleevent limits and partial-responses aren't possible.
;; 2001-Jan-15 TN send-partial sets filterproc so that incoming appleevents are processed while waiting for reply.
;; 2001-Jan-15 TN send-partial uses :no-reply as reply-mode, except when finishing so it knows whether peer has closed.
;; 2001-Jan-15 TN send-partial has the stream as first argument.
;; 2001-Jan-15 TN send-partial has new argument to tell when it is the first chunk of data, allowing reduced latency.
;; 2001-Jan-15 TN new partial-reply-handler for queued callbacks on partial responses.
;; 2000-Apr-25 TN io-buffer-advance has a errorp argument for MCL 4.3 or later.
;; 2000-Feb-27 TN Implementing read-http-data event to support large http data.
;; 2000-Feb-25 TN New get-header-value function. 
;; 2000-Feb-25 TN Renamed class cgi-output-stream to acgi-server and made it a buffered-io-stream.
;; 2000-Feb-25 TN *big-chunk-size* is set to 32K as this is the limit for AppleEvent data.
;; 2000-Jan-15 TN io-buffer-force-output signals an error if the stream is closed.
;; 1999-Jun-16 TN enable-cgi function
;; 1999-Jun-16 TN define-cgi-handler macro
;; 1999-Mar-03 TN Parameters for chunk sizes used to initialize the cgi-output-stream.
;; 1999-Mar-03 TN io-buffer-force-output doesn't send partial responses if count is zero.
;; 1998-Dec-06 TN Ignores making a reply if the Reply event in cgi-output is NIL. 
;; 1998-Dec-06 TN Don't resume-event if in event processors to allow unsuspended apple events.
;; 1998-Dec-02 TN Added *CGI-timeout* parameter to customize timeout for requests. 
;; 1998-Sep-27 TN Version 1.0 released
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#| EXAMPLE OF QUERYING A CGI APPLICATION FROM MCL:

1. Load this library into MCL.

2. Start up the "Interaction" CGI application found on the MCL CD-ROM
   or downloaded from <http://interaction.in-progress.com>


3. Evaluate the following to query the Interaction application via CGI:

(acgi:with-open-cgi (in "Interaction")
  (loop
    for line = (read-line in NIL)
    while line
    collect line))
|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :ccl)

(eval-when (:execute :load-toplevel)
  (require :defappleevents) ; "User Contributed Code:AppleEvents:defappleevents:defappleeevents.Lisp"
  (require :appleevent-toolkit)
  (require :io-buffer))

(defpackage acgi
  (:export
    "OPEN-CGI" 
    "WITH-OPEN-CGI"
    "OPEN-ACGI-SERVER"
    "ENABLE-CGI")
  (:import-from :ccl
    "AE-GET-PARAMETER-CHAR"
    "AE-PUT-PARAMETER-CHAR"
    "AE-ERRORP-HANDLER"
    "BUFFERED-CHARACTER-INPUT-STREAM-MIXIN"
    "BUFFERED-CHARACTER-OUTPUT-STREAM-MIXIN"
    "IO-BUFFER-BYTES-READ"
    "IO-BUFFER-OUTPTR"
    "IO-BUFFER-OUTSIZE"
    "IO-BUFFER-OUTCOUNT"
    "IO-BUFFER-OUTBUF"
    "IO-BUFFER-LISTEN"
    "IO-BUFFER-EOFP"
    "IO-BUFFER-ADVANCE"
    "IO-BUFFER-FORCE-OUTPUT"
    "STREAM-BYTES-TRANSMITTED"
    "STREAM-IO-BUFFER"
    "STREAM-FINISH-OUTPUT"
    "GET-SENDER-ADDRESS"
    "%FREE-AEDESC"
    "SET-SLOT-VALUE"
    "IO-BUFFER-BYTES-WRITTEN"
    "GET-ERROR-NUMBER"
    "GET-ERROR-STRING")
  (:use
    "CCL" 
    "COMMON-LISP"
    "DEFAPPLEEVENTS"))


(in-package :acgi)

(defappleevent acgi :|WWW½| :|sdoc|
  ((direct-object #$keyDirectObject)
   (path-args :|----|)
   (search-args :|kfor|)
   (username :|user|)
   (password :|pass|)
   (from-user :|frmu|)
   (client-address :|addr|)
   (server-address :|svnm|) ; The name of the web server
   (server-IP-port :|svpt|) ; The TCP port on which the server listens for connections
   (script-name :|scnm|)    ; The URL path to the CGI application
   (content-type :|ctyp|)   ; The MIME type of POST data, if present
   (referrer :|refr|)       ; The URL the visitor came from
   (user-agent :|Agnt|)     ; The product code name of the client software
   (action :|Kact|)         ; The type of CGI being run, e.g. "CGI", "ACGI" "PREPROCESSOR", or name of action 
   (action-path :|Kapt|)    ; When running as an action, this contains the path to the action.    
   (post-arguments :|post|) 
   (method :|meth|)
   (client-ip-address :|Kcip|)
   (full-request :|Kfrq|)   ; The entire text of the request as received by the server
   (directory-path :|DIRE|)
   (connection-ID :|Kcid|))  ; :desired-type #$typeinteger Identifies the connection
  ())

(defun set-reply (event reply value)
  (without-interrupts ;; to avoid change in active event during multiprocessing
    (ae-error (#_AESetTheCurrentEvent event))
    (ae-put-parameter-char reply #$keyDirectObject
      (if (typep value 'string) ;; always return a string! 
        value
        ""))))

(defconstant kilobyte 1024)

(defconstant max-post-parameter-size (* 20 kilobyte) 
  "Max length of post arguments (24Kb minus termination) up to WebStar 4 - use to ensure bw compatability. WebStar 3 may zero terminate the data before the end even if it is longer, so leave a few KB just in case")

(defun acgi-post-arguments (event)
  ; Required as this AppleEvent parameter is a terminated string with a potentially 
  ; too high HandleSize (at least for WebStar 3 and 4).
  (with-aedescs (data) 
    (ae-error (#_aegetparamdesc event :|post| #$typeChar data))
    (let* ((datahandle (rref data aedesc.datahandle))
           (size (#_GetHandleSize datahandle)))
      (with-dereferenced-handles ((ptr datahandle))
        (ccl::%str-from-ptr ptr (min size max-post-parameter-size))))))

(defappleevent partial :|WWW½| :|SPar|
  ((direct-object #$keyDirectObject)
   (connection-ID :|Kcid|)  ; :desired-type #$typeinteger
   (more :|Kmor| :desired-type #$typeBoolean))
   ())

(defun install-partial-handler (handler)
  "Install a handler for CGI partial events"
  (install-appleevent-handler :|WWW½| :|SPar| handler))

(defappleevent read-http-data :|WAPI| :|WRHD|
  ((direct-object #$keyDirectObject)
   (connection-ID :|Kcid| :desired-type #$typeinteger)
   (datalen :|LENG| :desired-type #$typeinteger))
  ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONDITIONS

(define-condition acgi-response-too-large (stream-error) ()
  (:report 
   (lambda (c s)
     (format s "Cannot make HTTP replies larger than ~A bytes without using partial ACGI responses"
       (io-buffer-outsize (stream-io-buffer (stream-error-stream c)))))))

(define-condition acgi-server-peer-closed () ()
  (:report 
   (lambda (c s)
     (declare (ignore c))
     (write-string "The ACGI server connection has been closed by peer" s))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FIFO QUEUE

;; Similar functionality is in the q.lisp module of WOOD!

(defstruct queue 
  head
  tail
  (lock (make-lock))
)

(defun queue-clear (queue)
  (ccl::cheap-free-list (queue-head queue))
  (setf (queue-head queue) NIL
        (queue-tail queue) NIL))

(defun queue-enqueue (queue item)
  "Appends the item at the end of the queue"
  (if (queue-tail queue)
    (setf (queue-tail queue)
          (setf (cdr (queue-tail queue))
                (ccl::cheap-cons item NIL)))
    (setf (queue-head queue)
          (setf (queue-tail queue)
                (ccl::cheap-cons item nil))))
  item)

#|
(defun queue-push (queue item) ;; # rename to queue-priority-enqueue?
  "Adds the item in the front of the queue"
  (cond
   ((queue-tail queue)
    (setf (queue-head queue)
          (ccl::cheap-cons item (queue-tail queue))))
   (T
    (setf (queue-head queue)
          (setf (queue-tail queue)
                (ccl::cheap-cons item nil)))))
  item)
|#

(defun queue-dequeue (queue)
  (let* ((head (queue-head queue)))
    (prog2
     (unless (cdr head)
       (setf (queue-tail queue) NIL))
     (ccl::pop-and-free head) ;; can only be used on symbols per MCL 4.3.1
     (setf (queue-head queue) head))))

(defun queue-empty-p (queue)
  (null (queue-head queue)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *acgi-handler* NIL)

(defun install-acgi-handler (handler)
  "Install a handler for CGI AppleEvents"
  (setf *acgi-handler* handler))

(defun enable-cgi (&optional (handler T))
  "Activate handling of CGI requests"
  (install-acgi-handler handler)
  ;; perhaps it should only activate appleevents?
;  (setq ccl::*event-mask* #$everyEvent)
)

(defun disable-cgi (&optional (handler NIL))
  (acgi::install-acgi-handler handler))

(defmethod application-acgi-handler (application event reply refcon)
  (unless (acgi-enqueue event reply)
    (application-acgi-overload-handler application event reply refcon)))

(defmethod application-acgi-overload-handler (application event reply &optional refcon)
  "Called when application is unable to handle the request due to temporary overloading"
  (declare (ignore application refcon))
  (set-reply event reply 
"HTTP/1.0 503 Service Overloaded


<HTML><HEAD><TITLE>Service Overloaded</TITLE></HEAD><BODY><H1>We are Swamped!</H1><P>Temporarily unable to handle the request due to an overload of requests. Please try again later.</P></BODY></HTML>"))


(defmethod application-acgi-disabled-handler (application event reply refcon)
  (declare (ignore application refcon))
  (set-reply event reply 
"HTTP/1.0 503 Service Unavailable


<HTML><HEAD><TITLE>Service Unavailable</TITLE></HEAD><BODY><H1>Not Available</H1><P>The service is not available.</P></BODY></HTML>"))

;; this allegedly sucks:
#+carbon-compat
(add-pascal-upp-alist 'acgi-ae-handler #'(lambda (procptr)(#_NewAEEventHandlerUPP procptr)))

(defpascal acgi-ae-handler (:pointer event :pointer reply :long refcon :word)
  ;; Modelled after defer-appleevent-handler in MCL kernel!
  (handler-case
    (case *acgi-handler*
      ((T) (application-acgi-handler *application* event reply refcon))
      ((NIL) (application-acgi-disabled-handler *application* event reply refcon))
      (otherwise (funcall *acgi-handler* *application* event reply refcon)))
    (error (c)
      (ae-put-parameter-char reply #$keyErrorString
                             (with-output-to-string (s)
                               (ccl::telnet-write-line s "HTTP/1.0 500 Internal Server Error")
                               (ccl::telnet-write-line s "")
                               (ccl::report-condition c s))
                             nil)
      (if (typep c 'ccl::appleevent-error)
        (ccl::oserr c)    ; return the error to the AppleEvent Manager
        #$errAEEventNotHandled))
    (:no-error (result)
     (declare (ignore result))
       #$noErr)))

(def-load-pointers enable-acgi-events ()
  (when (gestalt #$gestaltAppleEventsAttr #$gestaltAppleEventsPresent)
    ; install our handler into the real AppleEvent Manager dispatch table
    (#_AEInstallEventHandler :|WWW½| :|sdoc|
      acgi-ae-handler 0 nil)))

(defun suspend-ae (event reply)
  (ae-error (#_AESuspendTheCurrentEvent event))
  (let ((event (ccl::copy-aedesc event))
        (reply (ccl::copy-aedesc reply)))
    (values event reply)))

(defun resume-ae (event reply &optional free)
  "Resumes the event"
  (without-interrupts ;; to avoid that reply hangs on multiprocessing
    (unwind-protect
      (ae-error (#_AEResumeTheCurrentEvent event reply (%int-to-ptr #$kAENoDispatch) 0))
      (when free
         (%free-aedesc event nil)
         (when reply
           (%free-aedesc reply nil))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *acgi-queue* (make-queue))

(defvar *acgi-connections-count* 0
  "The number of ACGI connections currently active or enqueued")

(defun acgi-connections-count ()
  *acgi-connections-count*)

(defparameter *max-acgi-connections* 15
  "The max number of ACGI connections before new ones are refused")

#|
(defmacro with-assert-lock (lock &rest body &aux (tmp (gensym "LOCK")))
  "Assert that a resource is not shared between processes or interrupts, as a safeguard against possible inconsistencies in MCL processes"
  `(let ((,tmp ,lock))
     (declare (type lock ,tmp)
              (type process *current-process*))
     (ccl::locally (declare (optimize (speed 3) (safety 0)))
       (assert (store-conditional ,tmp NIL (or *current-process* T)) () "ACGI queue already locked by other process"))
     (unwind-protect 
       (progn ,@body)
       (ccl::locally (declare (optimize (speed 3) (safety 0)))
         (assert (store-conditional ,tmp (or *current-process* T) NIL) () "ACGI queue already unlocked by other process"))
)))
|#

(defun acgi-enqueue (event reply &rest args)
  "Enqueues an ACGI event and reply, returning a copy or NIL if at capacity"
  ;; Should always be called on interrupt or without allowing interrupts!
   (when (< *acgi-connections-count* *max-acgi-connections*)
     (incf *acgi-connections-count*)
     (multiple-value-bind (event reply)
       (suspend-ae event reply)
       (queue-enqueue *acgi-queue* 
        (ccl::cheap-cons event
         (ccl::cheap-cons reply
          args)))
       (values event reply))))

(defun next-acgi ()
  "Returns the next ACGI event as a value list - call resume-acgi after consumption"
  (let ((args))
    (declare (list args))
    ;; ## This would be so much nicer if process-wait returned the value of its test function!
    ;; ## Consider to use process-block instead of wait to avoid polling.
    ;; Eventually combined with process queueing.
    (process-poll "wait acgi request" 
                  #'(lambda (q)
                      (without-interrupts ; required as process-wait doesn't guarantee atomic execution! 
                       (or args ;; required for process-wait as the test function sometimes is called again!
                           (let ((values (queue-dequeue q)))
                             (when values
                               (setf args values)
                               )))))
                  *acgi-queue*)
    (values
     (ccl::pop-and-free args)
     (ccl::pop-and-free args)
     args)))

(defun resume-acgi (event reply)
  (handler-case
    (unwind-protect
      (resume-ae event reply T)
      (without-interrupts
       (decf *acgi-connections-count*)))
    (appleevent-error (c)
     (case (ccl::oserr c) 
       (#.#$errAEUnknownAddressType ; happens when content has been sent in partial events...
         NIL)
       (otherwise
        (signal c))))))

(defun call-next-acgi (function &aux result)
  "Apply the event handling function to the next queued acgi event"
  (multiple-value-bind (event reply args)
    (next-acgi)
    (unwind-protect
      (handler-case 
        (setf result
          (apply function event reply args))
        (appleevent-error (c)
         (ae-put-parameter-char reply #$keyErrorString
          (with-output-to-string (s)
            (ccl::report-condition c s))
          nil)
         (format *error-output* "~%> Error while handling ACGI AppleEvent:~%> ")
         (ccl::report-condition c *error-output*)))
      (unless (eq result :suspended)
        (resume-acgi event reply)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro with-open-cgi ((label &optional filename &rest rest) 
                         &rest body)
  "Open a stream with a request to a CGI application"
  `(with-open-stream (,label (open-cgi ,filename
                               ,@(apply #'append rest 
                                   (remove-if-not #'keywordp body 
                                      :key #'(lambda (item)
                                               (when (listp item)
                                                  (car item)))))))
     ,@(remove-if #'keywordp body 
         :key #'(lambda (item)
                  (when (listp item)
                    (car item))))))

(defun open-cgi (filename &rest rest)
  "Opens a stream to read a response for a CGI request"
  (apply #'make-instance 'cgi-input-stream
    :filename (or filename (mac-namestring (ccl::get-app-pathname)))
    rest))

(defconstant max-last-id (min most-positive-fixnum 
                              (1- #.(expt 256 4))))

(defvar last-id 0)

(declaim (fixnum last-id))

(defun generate-id ()
  "Generates a long integer to identify a CGI connection"
  (without-interrupts
   (if (<= (incf last-id) max-last-id)
     last-id
     ;; Ensures that last-id always is a fixnum:
     (setf last-id
           (mod last-id max-last-id)))))

(defvar cgi-connections (make-hash-table :size 8))

(defparameter *CGI-timeout* 900
  "How many ticks before a request to a CGI application times out")

(defclass cgi-input-stream (input-stream)
  ((filename :reader filename :initarg :filename)
   (response :accessor response :type list :initform NIL)
   (index :initform 0)
   (end :initform 0)
   (completed :accessor completed-p :initform NIL
     :documentation "True when the full response has been received from the CGI")
   (timeout :accessor timeout 
     :initform *CGI-timeout*
     :initarg :timeout
     :documentation "Max time to wait without a response from the CGI")
   (id :reader id :initform (generate-id)))
  (:documentation "Stream to send a CGI request and receive an asynchronous response"))

(defmethod initialize-instance :after ((stream cgi-input-stream) 
  &key filename mode timeout
     ;; CGI 
       server-software 
       server-name
       gateway-interface
       server-protocol
       server-port
       request-method
       path-info
       path-translated
       script-name       
       query-string
       remote-host 
       remote-addr
       auth-type
       remote-user
       remote-ident
       content-type
       content-length
       http-user-agent
       http-accept
       http-referer
     ;; Mac Extensions:
       password
       post-arguments
       full-request
       action
       action-path
       directory-path)
  ;; Declare unused arguments to ensure that we aren't reminded about that these needs to be used in some way
  (declare (ignore mode timeout server-software gateway-interface
		   server-protocol path-translated auth-type remote-ident content-length http-accept))
  (setf (gethash (id stream) cgi-connections) stream)
  (with-aedescs (event reply target)
      (create-named-process-target target (mac-file-namestring filename))
      (make-acgi event target
        :username (or remote-user "")
        :password (or password "")
        :from-user ""
        :client-address (or remote-host remote-addr "")
        :server-address (or server-name "")
        :server-ip-port (or server-port "80")
        :method (or request-method "GET")
        :script-name (or script-name "/")
        :content-type (or content-type "")
        :referrer (or http-referer "")
        :user-agent (or http-user-agent "")
        :action (or action "PREPROCESSOR")
        :action-path (or action-path "")
        :post-arguments (or post-arguments "")
        :search-args (or query-string "")
        :path-args (or path-info "")
        :client-ip-address (or remote-addr "0.0.0.0")
        :full-request (or full-request "")
        :directory-path (or directory-path "")
        :connection-id (id stream))
      (install-queued-reply-handler event 'cgi-reply-handler (id stream))
      (send-appleevent event reply 
         :reply-mode :queue-reply
         :can-switch-layer T
         :timeout (timeout stream)
         :filterproc appleevent-filter-proc)))

(defmethod append-response ((stream cgi-input-stream) response &optional more)
  (assert (not (completed-p stream)) () 
    "A CGI ~A already claimed the response is complete, yet it sent an event with more data" (filename stream))
  (without-interrupts
    (unless (or (null response) (equal response ""))
      (cond
        ((response stream)
          (setf (response stream)
            (append (response stream)
              (list response))))
        (T
          (set-slot-value stream 'index 0)
          (set-slot-value stream 'end (length response))
          (setf (response stream) (list response)))))
     (setf (completed-p stream) (not more)))
     response)

(defmethod cgi-reply-handler (application appleevent reply refcon)
  (declare (ignore application reply))
  ;; ## Refcon can just as well be the stream itself to save a lookup?
  (let ((stream (gethash refcon cgi-connections)))
    (when stream ;; # Can be made more efficient by using a PTR or AEDESC instead of character string... 
      (let ((response (ae-get-parameter-char appleevent #$keyDirectObject nil)))
        (unless (equal response "<SEND_PARTIAL>")
          (append-response stream response))))))

(defmethod cgi-partial-handler (application event reply refcon)
  (declare (ignore application refcon))
  (let* ((id (partial-connection-id event))
         (stream (gethash id cgi-connections))
         (response (ae-get-parameter-char event #$keyDirectObject nil))
         (more (partial-more event)))
    (cond
      (stream
        (append-response stream response more))
      (T
        (ccl::ae-put-parameter-longinteger reply #$keyErrorNumber #$userCanceledErr nil)
        (ccl::ae-put-parameter-char reply #$keyErrorString "Request Aborted" nil)))))

(install-partial-handler #'cgi-partial-handler)

(defmethod stream-advance ((stream cgi-input-stream))
  "Called when there is no data in the input buffer - returns T if there is data afterwards"
  (unless
    (process-wait-with-timeout "CGI Response" (timeout stream)
      #'(lambda ()
          (or 
             (stream-listen stream)
             (stream-eofp stream))))
    (error "Timeout after waiting ~A ticks for CGI response for ~A" (timeout stream) stream))
  (not (stream-eofp stream)))

(defmethod stream-listen ((stream cgi-input-stream))
  (if (response stream) 
    (not (stream-eofp stream))))

(defmethod stream-tyi ((stream cgi-input-stream))
  (without-interrupts
    (when (or (response stream)
              (stream-advance stream))
      (let ((idx (slot-value stream 'index)))
        (set-slot-value stream 'index (ccl::%i+ idx 1))
        (prog1
          (elt (first (response stream)) idx)
          (when (= (slot-value stream 'index) (slot-value stream 'end))
            (pop (response stream))
            (set-slot-value stream 'index 0)
            (set-slot-value stream 'end (length (first (response stream))))))))))

(defmethod stream-untyi ((stream cgi-input-stream) char)
  (without-interrupts
    (let ((index (slot-value stream 'index)))
      (cond
        ((= index 0)
          (push (string char) (response stream))
          (set-slot-value stream 'index 0)
          (set-slot-value stream 'end 1))
        (T 
          (unless (eq char (aref (first (response stream)) (1- index)))
            (error "Attempt to unread illegal char ~S" char))
          (set-slot-value stream 'index (1- index)))))))

(defmethod stream-clear-input ((stream cgi-input-stream))
  (without-interrupts 
    (setf (response stream) NIL)
    (set-slot-value stream 'index 0)
    (set-slot-value stream 'end 0)))

(defmethod stream-eofp ((stream cgi-input-stream))
  (and 
    (null (response stream))
    (completed-p stream)))

(defmethod stream-close :before ((stream cgi-input-stream))
  (remhash (id stream) cgi-connections))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ANSWERING A CGI REQUEST:

(defun open-acgi-server (&optional event reply)
  (make-instance 'acgi-server :event event :reply reply))

(defparameter *allow-partial-responses* t 
  "If true, the response can be passed back to the server as partial events, resulting in lower latency and no size limitations")

(defparameter *initial-chunk-size* (* 4 kilobyte))
(defparameter *big-chunk-size* (* 32 kilobyte))

(defclass acgi-server (suspendable-stream-mixin
                       ccl::BUFFERED-CHARACTER-io-STREAM-MIXIN
                       ccl::buffered-binary-io-stream-mixin)
  ((event :reader ae-event :initarg :event)
   (reply :reader ae-reply :initarg :reply
     :documentation "Optional pointer for an AE record for the reply")
   (release-p :reader release-p :initform NIL
     :documentation "True if the ae event and reply should be released on completion")       
   (data-aedesc :initform NIL
     :documentation "The most recently retrieved HTTP data")
   (content-length :type fixnum :initform NIL
     :documentation "The total length of the request body")
   (id :accessor id)
   (error :initform NIL :documentation "A condition if a reply failed"))
  (:default-initargs
   :outsize (* 16 kilobyte))
  (:documentation "A stream for returning the reply of a request using appleevents"))

(defmethod initialize-instance ((stream acgi-server) &rest rest &key event reply outsize &aux replace?)
  (declare (dynamic-extent rest))
  (unless event
    (setf replace? T)
    (multiple-value-setq (event reply)
      (next-acgi)))
  (setf (id stream)
    (when *allow-partial-responses*
      (handler-case
        (acgi-connection-id event)
        (appleevent-error () 
          (setf *allow-partial-responses* NIL)))))
  (cond
    ((id stream)
      (call-next-method)
      ;; speed up response by providing a small chunk first:
      (setf (io-buffer-outcount (stream-io-buffer stream))
        *initial-chunk-size*))
    (T
      (apply #'call-next-method stream
        :outsize (max *big-chunk-size* outsize)
        rest)))
  (when replace?
    ;; need to set slots here as call-next-method overwrites otherwise:
    (setf (slot-value stream 'event) event
          (slot-value stream 'reply) reply
          (slot-value stream 'release-p) T)))

(defmethod stream-close ((stream acgi-server))
  (unwind-protect
    (when (open-stream-p stream)
      (stream-finish-output stream))
    (call-next-method)
    (with-slots (data-aedesc event reply) stream
      (when data-aedesc
        (%free-aedesc data-aedesc)
        (setf data-aedesc NIL))
      (unwind-protect
        (without-interrupts ; a stream that is suspended may change release-p
         (when (and event (release-p stream))
           (resume-acgi event reply)
           (setf (slot-value stream 'release-p) NIL)))
        (slot-makunbound stream 'event)
        (slot-makunbound stream 'reply))))
  NIL)

(defmethod io-buffer-advance ((server acgi-server) io-buffer readp #+ccl-4.3 &optional #+ccl-4.3 errorp)
  #+ccl-4.3 
  (declare (ignore errorp))
  (unless readp
    (return-from io-buffer-advance
      (not (IO-BUFFER-EOFP server io-buffer)))) 
  (unless (IO-BUFFER-EOFP server io-buffer) ;; sets the content-length if necessarry!
    (with-slots (data-aedesc content-length) server
      (if data-aedesc
        (%free-aedesc data-aedesc) ;; disposes just the data, not the descriptor itself!
        (setf data-aedesc (make-record :AEDesc)))
      (let ((position (io-buffer-bytes-read io-buffer))) 
        (cond
          ((and (zerop position)
             (progn
               (ae-error (#_aegetparamdesc (ae-event server) :|post| #$typeChar data-aedesc))
               (let ((size (min max-post-parameter-size 
                               (#_GetHandleSize (rref data-aedesc aedesc.datahandle)))))          
                (setf (ccl::io-buffer-incount io-buffer) size)
                ;; Move the read pointer of the server to the second part of the content.
                ;; Can save latency by doing this just before second advance instead.
                ;; On the other hand, perhaps it is good to give the server a little time to fill up?
                (when (and (plusp size)
                           (< size content-length))
                  (with-aedescs (event reply) 
                    (make-read-http-data event (get-sender-address (ae-event server) (ae-reply server))
                      :connection-id (acgi-connection-id (ae-event server))
                      :datalen size)
                    (send-appleevent event reply :reply-mode :no-reply)))
                (plusp size)))))
          (T
            (with-aedescs (event reply)
              (make-read-http-data event (get-sender-address (ae-event server) (ae-reply server))
                :connection-id (acgi-connection-id (ae-event server))
                :datalen (min #.(* 16 kilobyte) (- content-length position)))
              (let (count)
                (flet ((read-http-data-reply-handler (application event reply stream)
                         (declare (ignore application reply))
                         (with-slots (data-aedesc) stream
                           (ae-error (#_aegetparamdesc event #$keyDirectObject #$typeChar data-aedesc))
                           (setf count (#_GetHandleSize (rref data-aedesc aedesc.datahandle))))))
                  (install-queued-reply-handler event #'read-http-data-reply-handler server)
                  (send-appleevent event reply :reply-mode :queue-reply)
                  (process-wait "acgi read data" (lambda () count))
                  (setf (ccl::io-buffer-incount io-buffer) count))))))
        (with-dereferenced-handles ((ptr (rref data-aedesc aedesc.datahandle)))
          (%setf-macptr (ccl::io-buffer-inbuf io-buffer) ptr)
          (%setf-macptr (ccl::io-buffer-inptr io-buffer) (ccl::io-buffer-inbuf io-buffer)))
        position))))

(defmethod IO-BUFFER-EOFP ((server acgi-server) io-buffer)
  (with-slots (content-length) server
    (>= (io-buffer-bytes-read io-buffer) 
        (or content-length
            (setf content-length 
                  (or (get-header-value :content-length server 'number)
                      0))))))

(defmethod io-buffer-force-output ((stream acgi-server) io-buffer count finish-p)
  (let ((outbuf (io-buffer-outbuf io-buffer))
        (event (ae-event stream))
        (reply (ae-reply stream))
        (id (id stream)))
    (handler-case
      (cond
       ((not (open-stream-p stream))
          (error "Cannot force output for the closed stream ~A" stream))
       ((null reply))
       ((and finish-p
             (or (= count (io-buffer-bytes-written io-buffer)) ; only one chunk
                 (null id)))
        (ae-put-parameter-string-ptr reply #$keyDirectObject 
                                           outbuf count)
        ;; ## Possible optimalization by forcing result to be transmitted here, as we are done!
        ;; # will this cause a problem if event later is resumed again?
        ;(when (neq ccl::*event-processor* *current-process*) 
        ;  (resume-event event reply t))
        )
       (id
        (when (or (> count 0) finish-p)
          (send-partial stream (get-sender-address event reply) id
                outbuf count (= count (io-buffer-bytes-written io-buffer))
                (not finish-p))
          ;; # are these any point if we finish anyway?
          (%setf-macptr (io-buffer-outptr io-buffer) outbuf)
          (setf (io-buffer-outcount io-buffer)
                (io-buffer-outsize io-buffer))))
       ((= (io-buffer-outsize io-buffer) count)
        (assert (null id))
        (stream-abort stream)
        (error 'acgi-response-too-large :stream stream))
       (T
        (warn "Premature force output for an acgi server stream without partial responses")))
      (acgi-server-peer-closed (condition)
        (stream-abort stream)
        (signal condition))
      (appleevent-error (condition)
        (stream-abort stream)
        (error condition)))
    count))

(defmethod ccl::stream-position ((stream acgi-server) &optional value)
  (assert (null value) () "Cannot set the position of an ACGI stream")
  (stream-bytes-transmitted stream))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MCL optimized functions to extract an HTTP header from a ptr (usable beyond ACGI events!)

;; These should ideally not be in this package - but they are required for now :-(

(defun get-header-value (name server &optional type)
  (with-aedescs (buffer)
    (ae-error (#_aegetparamdesc (ae-event server) :|Kfrq| #$typeChar buffer))
    (let ((datahandle (rref buffer aedesc.datahandle)))
      (when datahandle
        (with-dereferenced-handles ((ptr datahandle))
          (%get-header-value (string name) ptr (#_GetHandleSize datahandle) type))))))

(defun %get-header-value (name ptr size &optional type)
  (multiple-value-bind (value-ptr size)
    (%get-header-value-ptr (string name) ptr size)
    (ecase type
      ((nil string)
        (ccl::%str-from-ptr value-ptr size))
      (number ;; ## need to read from ptr as number is digits, not binary...
        (let* ((*read-eval* NIL)
               (number (read-from-string (ccl::%str-from-ptr value-ptr size))))
          (assert (numberp number) () "Missing or erronous ~A content length field in HTTP header" number)
          number)))))

(defun %get-header-value-ptr (name ptr size &optional (length (length name)))
  "Returns a pointer to the field value in a header, with length as second value"
  ;; Field name should always be uppercase.
  (locally (declare (string name)(macptr ptr) (fixnum size length)
                    (optimize (speed 3) (safety 0))))
  (flet ((matching-header-p (name ptr offset)
           (declare (string name)(macptr ptr)(fixnum offset))
           (dotimes (ix length (= #.(char-code #\:) (%get-byte ptr offset)))
             (when (neq (schar name ix)
                        (char-upcase (code-char (%get-byte ptr offset))))
               (return))
             (incf offset)))
         (next-start (ptr offset)
           (declare (fixnum offset)(macptr ptr))
           (loop
             until (<= size offset)
             until (and (= #.(char-code #\cr) (%get-byte ptr (incf offset)))
                        (= #.(char-code #\lf) (%get-byte ptr (incf offset)))))
           (if (> size offset)
             (1+ offset)
             size)))
    (declaim (inline matching-header-p next-start))
    (do* ((start (next-start ptr 0) next)
          (next))
         ((or (= (+ 2 start) (setf next (next-start ptr start))) (< size (+ start length 1)))
            NIL)
       (declare (fixnum start next))
       (when (matching-header-p name ptr start)
         (return-from %get-header-value-ptr
           (let ((offset (+ start length 2)))
             (values (%inc-ptr ptr offset) 
                     (if (= next size) (- size offset) (- next offset 2) ))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ae-put-parameter-string-ptr (the-desc keyword ptr length &optional (errorp T))
  "Assign a pointer to a string as the parameter for an apple event"
  ;; Careful - the pointer should not be deallocated by LISP later on!
  (ae-errorp-handler
    errorp
    (ae-error (#_AEPutParamPtr the-desc keyword #$typeChar
                 ptr length))))

(defun ae-put-parameter-boolean (the-desc keyword value &optional (errorp t))
  ;; perhaps Digitool should add this with the other ae-put functions?
  (rlet ((buffer :boolean))
    (%put-word buffer (if value -1 0))
    (ae-errorp-handler
      errorp
      (ae-error (#_AEPutParamPtr the-desc keyword #$typeBoolean buffer
                 (record-length :boolean))))))

(defmethod send-partial-reply-handler (application event reply stream)
  "Handles the reply when sending a partial response with :queue-reply as mode"
  (declare (ignore application reply))
  (let ((error-number (get-error-number event nil)))
    (when (and error-number
               (not (= error-number #$noerr)))
      (setf (slot-value stream 'error)
            (make-condition 'appleevent-error
                            :oserr error-number
                            :error-string "Partial reply failed" ; (get-error-string event nil)
)))))

(defun send-partial (stream target connection-id ptr length &optional first-p more-p)
  "Sends a partial response with the string referenced by the ptr"
  ;; target is available using sender-address on an incoming event.
 (without-interrupts
  (let ((error (slot-value stream 'error)))
    (when error
      (setf (slot-value stream 'error) nil)
      (if (and (typep error 'appleevent-error)
               (eql (ccl::oserr error) #$errAEEventNotHandled))
        (signal 'acgi-server-peer-closed)
        (signal error))
      (return-from send-partial)))
  (with-aedescs (event reply)
    (make-partial event target
      :connection-id connection-id)
    (ae-put-parameter-boolean event :|Kmor| more-p)
    (ae-put-parameter-string-ptr event #$keyDirectObject ptr length)
    (when more-p
      (install-queued-reply-handler event #'send-partial-reply-handler stream))
    (send-appleevent event reply
       ;; Don't wait for reply to avoid holding up other processes included user interactivity
       ;; (see http://developer.apple.com/techpubs/mac/IAC/IAC-105.html#HEADING105-0.):
     :reply-mode (if more-p :queue-reply :no-reply)
       ;; Process incoming AppleEvents while waiting:
       ;; :filterproc appleevent-filter-proc
       ;; Put first chunk in begining of queue to reduce latency: 
     :priority (if first-p #$kAEHighPriority #$kAENormalPriority))))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SUSPENDABLE STREAMS (consider to move into separate module!)

(defclass suspendable-stream-mixin ()
 ;; # put in other module? use on broadcast-stream instead!
  ((opened :initform 1
     :documentation "How many times to call stream-close before stream closes")))

(defmethod stream-close :around ((stream suspendable-stream-mixin))
  (when (zerop (without-interrupts (decf (slot-value stream 'opened))))
    (call-next-method)))

(defmethod ccl::stream-suspend ((stream suspendable-stream-mixin))
  "Return the stream after setting it to ignore the next stream-close"
  (without-interrupts (incf (slot-value stream 'opened)))
  stream)

(defmethod ccl::stream-suspended-p ((stream suspendable-stream-mixin))
  "Return the stream after setting it to ignore the next stream-close"
  (> (slot-value stream 'opened) 1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#| ACGI SERVER DEMONSTRATION

First enable acgi functionality:

(enable-cgi)

Try the following:

1. Start a stream acgi listener:

(process-run-function "ACGI Listener"
  (lambda ()
    (loop
      (with-open-stream (stream (open-acgi-server))
        ;(ccl::telnet-write-line stream "HTTP/1.0 200 OK")
        ;(ccl::telnet-write-line stream "")
        (ccl::telnet-write-line stream "Terje was here!")))))

2. Make acgi request to self:

(with-open-cgi (in)
  (ccl::telnet-read-line in))

------------
ALTERNATIVES
------------

;; HANDLE SINGLE QUEUED EVENT:

(process-run-function "ACGI Handler" #'call-next-acgi
  (lambda (event reply)
    (format *debug-io* "ACGI Event: ~A ~A~%" event reply)))

;; PRIMITIVE ACGI LISTENER:  

(process-run-function "Primitive ACGI Listener"
  (lambda ()
    (loop
      (call-next-acgi
       (lambda (event reply)
         (set-reply event reply 
           (with-output-to-string (out)
             (write-line "Terje was here too!" out))))))))

;; BASIC ACGI LISTENER WITH STREAM:  

(process-run-function "Basic Stream ACGI Listener"
  (lambda ()
    (loop
      (call-next-acgi
       (lambda (event reply)
         (with-open-stream (stream (open-acgi-server event reply)) 
           (write-line "Terje was here also!" stream)))))))


|#