remobe ROFL and add validation
[clinton/lisp-on-lines.git] / src / ucw / standard-components.lisp
1 (in-package :lisp-on-lines-ucw)
2
3 (defclass lisp-on-lines-action (ucw-standard::standard-action)
4 ((layer-context :accessor action-layer-context
5 :initform nil
6 :initarg :layer-context))
7 (:metaclass closer-mop:funcallable-standard-class))
8
9
10 (setf ucw-standard::*default-action-class* 'lisp-on-lines-action)
11
12
13
14 (defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
15 (let ((next-method (lambda ()
16 (layered-call-action
17 action application session frame
18 (lambda ()
19 (call-next-method))))))
20 (let ((layer-context (action-layer-context action)))
21 (if layer-context
22 (funcall-with-layer-context layer-context next-method)
23 (funcall next-method)))
24 ))
25
26 (defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
27 (let ((lol::*invalid-objects* (make-hash-table)))
28 (handler-bind ((lol::validation-condition
29 (lambda (c)
30 (let ((object (lol::validation-condition-object c))
31 (attribute (lol::validation-condition-attribute c)))
32
33
34 (setf (gethash object lol::*invalid-objects*)
35 (cons (cons attribute c)
36 (gethash object lol::*invalid-objects*)))))))
37 (call-next-method))))
38
39
40 (define-layered-function layered-call-action (action application session frame next-method)
41 (:method (action application session frame next-method)
42 (funcall next-method)))
43
44
45 (contextl:define-layered-method layered-call-action
46 :in-layer #.(lol::defining-description 'lol::validate)
47 :around ((action lisp-on-lines-action) application session frame next-method)
48 (call-next-method)
49
50 )
51
52
53
54 (defclass described-component-class (described-class standard-component-class )
55 ())
56
57
58
59 (defcomponent standard-window-component
60 (ucw-standard::basic-window-component)
61 ((body
62 :initform nil
63 :accessor window-body
64 :component t
65 :initarg :body)))
66
67 (defmethod render-html-head ((window standard-window-component))
68 (let* ((app (context.application *context*))
69 (url-prefix (application.url-prefix app)))
70 (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
71 (awhen (window-component.title window)
72 (<:title (if (functionp it)
73 (funcall it window)
74 (<:as-html it))))
75 (awhen (window-component.icon window)
76 (<:link :rel "icon"
77 :type "image/x-icon"
78 :href (concatenate 'string url-prefix it)))
79 (dolist (stylesheet (effective-window-stylesheets window))
80 (<:link :rel "stylesheet"
81 :href stylesheet
82 :type "text/css"))))
83
84 (defmethod render-html-body ((window standard-window-component))
85 (render (window-body window)))
86
87 (defcomponent info-message ()
88 ((message :accessor message :initarg :message)))
89
90 (defmethod render ((m info-message))
91 (<:div
92 :class "info-mssage"
93 (<:as-html (message m)))
94 (<lol:a :action (answer-component m nil) "Ok"))
95
96