remobe ROFL and add validation

[clinton/lisp-on-lines.git] / src / ucw / standard-components.lisp

(in-package :lisp-on-lines-ucw)

(defclass lisp-on-lines-action (ucw-standard::standard-action) 
  ((layer-context :accessor action-layer-context
		  :initform nil
		  :initarg :layer-context))
  (:metaclass closer-mop:funcallable-standard-class))


(setf ucw-standard::*default-action-class* 'lisp-on-lines-action)



(defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
  (let ((next-method (lambda ()
		       (layered-call-action 
			action application session frame 
			(lambda () 
			  (call-next-method))))))
    (let ((layer-context (action-layer-context action)))
      (if layer-context 
	  (funcall-with-layer-context layer-context next-method)
	  (funcall next-method)))
    ))

(defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
     (let ((lol::*invalid-objects* (make-hash-table)))
       (handler-bind ((lol::validation-condition 
		       (lambda (c)
			 (let ((object (lol::validation-condition-object c))
			       (attribute (lol::validation-condition-attribute c)))


			   (setf (gethash object lol::*invalid-objects*)
				 (cons (cons attribute c)
				       (gethash object lol::*invalid-objects*)))))))
       (call-next-method))))


(define-layered-function layered-call-action (action application session frame next-method)
  (:method (action application session frame next-method)
    (funcall next-method)))


(contextl:define-layered-method layered-call-action 
   :in-layer #.(lol::defining-description 'lol::validate)
   :around ((action lisp-on-lines-action) application session frame next-method)
   (call-next-method)

   )



(defclass described-component-class (described-class standard-component-class )
  ())



(defcomponent standard-window-component 
  (ucw-standard::basic-window-component)
  ((body
    :initform nil
    :accessor window-body
    :component t
    :initarg :body)))

(defmethod render-html-head ((window standard-window-component))
  (let* ((app (context.application *context*))
	 (url-prefix (application.url-prefix app)))
    (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
    (awhen (window-component.title window)
      (<:title (if (functionp it)
		   (funcall it window)
		   (<:as-html it))))
    (awhen (window-component.icon window)
      (<:link :rel "icon"
	      :type "image/x-icon"
	      :href (concatenate 'string url-prefix it)))
    (dolist (stylesheet (effective-window-stylesheets window))
      (<:link :rel "stylesheet"
	      :href stylesheet
	      :type "text/css"))))

(defmethod render-html-body ((window standard-window-component))
  (render (window-body window)))

(defcomponent info-message ()
  ((message :accessor message :initarg :message)))

(defmethod render ((m info-message))
  (<:div
   :class "info-mssage" 
   (<:as-html (message m)))
   (<lol:a :action (answer-component m nil) "Ok"))