;; -*- lisp -*-

(in-package :it.bese.ucw.core)

;;;; ** STANDARD-SESSION-FRAME

(defmacro register-action ((&rest args &key (through-redirect nil)
                                  (frame '(context.current-frame *context*))
                                  &allow-other-keys)
                           &body body)
  "Makes a new action and registers it in FRAME. For more details see make-action."
  (remf-keywords args :frame :through-redirect)
  (with-unique-names (action target-url target-uri)
    (if through-redirect
        `(let ((,target-uri (nth-value 1 (action-href
                                          (register-action (,@args)
                                            ,@body)))))
          ;; TODO better invocation isolation id that has some uniqueness guarantees
          (add-query-parameter-to-uri ,target-uri +action-invocation-parameter-name+
                                      (random 100000))
          (let* ((,target-url (print-uri-to-string ,target-uri))
                 (,action (make-action-body (:class 'basic-action :call-render nil :make-new-frame nil)
                            (handle-raw-request (:content-type "text/html" :with-yaclml-stream t)
                              (let ((response (context.response *context*)))
                                (setf (get-header response "Status") "302"
                                      (get-header response "Location") ,target-url)
                                (<:html
                                 (<:head
                                  (<:title "302 - Redirect"))
                                 (<:body
                                  (<:p "Page has moved "
                                       (<:a :href ,target-url
                                            (<:as-html "here"))))))))))
            (register-action-in-frame ,frame ,action)
            ,action))
        `(let ((,action (make-action-body (,@args) ,@body)))
          (register-action-in-frame ,frame ,action)
          ,action))))

(defmacro register-ajax-action ((&rest args &key (class ''ajax-action) &allow-other-keys) &body body)
  (remf-keywords args :class)
  `(register-action (:class ,class ,@args)
    ,@body))

(defmethod register-action-in-frame ((frame standard-session-frame) action)
  (setf (action-id action) (insert-with-new-key (frame.actions frame) +action-id-length+ action)))

(defmethod find-action ((frame standard-session-frame) (action-id string))
  (gethash action-id (frame.actions frame)))

(defmethod find-action ((f standard-session-frame) (action-id list))
  (find-action f (car action-id)))

(defmethod find-action ((f standard-session-frame) (action-id null))
  nil)

(defmethod (setf find-action) (funcallable (frame standard-session-frame) (action-id string))
  (setf (gethash action-id (frame.actions frame))
        funcallable))

(defstruct (callback-entry (:conc-name callback-) (:constructor %make-callback-entry))
  (lambda nil :type function)
  (dependencies '() :type list) ; a list of callbacks that should be run before this one
  (executed nil :type boolean)  ; while callbacks are processed this flag is used to mark execution
  (priority 0 :type fixnum)     ; callbacks will be called in the order determined by this priority
  (id nil :type string))

(defun make-callback (lambda &key (priority 0))
  "Creates a new (unregistered) callback.

When registered and the request arrives LAMBDA will be passed the
value (a string) associated with the input. If NAME is not
provided, or NIL, a random name will be generated.

Returns the freshly created callback-entry struct."
  (%make-callback-entry :lambda lambda :id "unregistered" :priority priority))

(defun register-callback (lambda &rest args &key
                                 (frame (context.current-frame *context*))
                                 id &allow-other-keys)
  "Makes a new callback and registers it in FRAME. For more details see make-callback."
  (remf-keywords args :frame :id)
  (let ((entry (apply #'make-callback lambda args)))
    (register-callback-in-frame frame entry :id id)
    (callback-id entry)))

(defmethod register-callback-in-frame ((frame standard-session-frame) callback &key id)
  "Registers a callback-entry in this frame. When passed in an
action generated by FRAME then CALLBACK will be called passing it the value of
the corresponding request param."
  (unless id
    (setf id (new-callback-id frame)))
  (setf (gethash id (frame.callbacks frame)) callback)
  (setf (callback-id callback) id)
  callback)

(defun new-callback-id (&optional (frame (context.current-frame *context*)))
  ;; we insert a nil here to mark that this callback id is used even if no callback
  ;; is gets registered under this key
  (insert-with-new-key (frame.callbacks frame) +action-id-length+ nil))

(defun prepare-callbacks (frame request)
    (let ((callbacks (make-hash-table))
	(priority-counter 0))
    (map-parameters 
     request
     (lambda (param value)
       (unless (member param (list +action-parameter-name+
				   +action-invocation-parameter-name+
				   +frame-parameter-name+
				   +session-parameter-name+)
		       :test #'string=)
	 (let ((callback (gethash param (frame.callbacks frame))))
	   
	 (if callback 
	     (progn
	       ;; Copy callback before mutating.
	       ;; NB: Do we need to access these elsewhere ever?
	       (setf callback (copy-callback-entry callback))
	       (ucw.rerl.actions.dribble "Enqueue callback with id ~S in frame ~S (value is ~S)."
					 param frame value)

	     (when (= 0 (callback-priority callback))
	       (setf (callback-priority callback)
		     (decf priority-counter)))
	     
	     (setf (callback-executed callback) nil) 
	     (setf (gethash callback callbacks) value))
	   (ucw.rerl.actions.debug "No callback found with id ~S in frame ~S (value is ~S)."
				   param frame value))))))
     callbacks))


(defmacro defmethod-and-defmethod/cc (name &body body)
  `(progn 
    (defmethod ,name ,@body)
    (defmethod ,(intern (format nil "~A~A" name '/cc)) ,@body)))
    
(defmethod call-callbacks (action (frame standard-session-frame) (request request))
  "Execute all the callback lambda in CONTEXT's request.

Simply goes through the request's params and, for every param
which isn't +action-parameter-name+, +frame-parameter-name+ or
+session-parameter-name+, looks up and call the associated lambda
in the current frame. Makes sure dependent callbacks are executed after
their dependencies."
  (let* ((callbacks (prepare-callbacks frame request))
        (found-callbacks (let ((count (hash-table-count callbacks)))
                            (unless (zerop count)
                              count))))
    (flet ((ready-to-execute-p (callback)
             (iter (for dependency in (callback-dependencies callback))
                   (always (callback-executed dependency)))))
      (iter (with done-something = nil)
            (iter (for (callback value) in-hashtable callbacks)
                  (when (ready-to-execute-p callback)
                    (collect (cons callback value) into to-be-called :result-type vector))
                  (finally
                   (setf to-be-called (sort to-be-called #'> :key (lambda (el)
                                                 (callback-priority (car el)))))
                   (iter (for (callback . value) in-vector to-be-called)
                         (ucw.rerl.actions.debug "Calling callback ~S" callback)
			 (remhash callback callbacks)
                         (setf (callback-executed callback) t)
                         (funcall (callback-lambda callback) value)
                         (setf done-something t))))
            (while done-something)
            (setf done-something nil))
      (unless (zerop (hash-table-count callbacks))
        (cerror "Ignore them and continue processing the action"
                "Circular dependency found in callbacks of frame ~S, involved callbacks are: ~S!"
                frame (hash-table-keys callbacks))))
    found-callbacks))

(defmethod make-next-frame ((session basic-session) (previous-frame standard-session-frame) new-id)
  (make-instance (session-frame-class-of session)
                 :effective-backtracks (clone-effective-backtracks
                                        (context.session *context*)
                                        previous-frame)
                 :window-component (frame.window-component previous-frame)
                 :id new-id))

(defmethod make-next-frame ((session basic-session) (f null) new-id)
  (make-instance (session-frame-class-of session) :id new-id))

;; Copyright (c) 2003-2005 Edward Marco Baringer
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - 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.
;; 
;;  - Neither the name of Edward Marco Baringer, nor BESE, 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
;; OWNER 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.