src/ucw/ucw-test.lisp

   1 (in-package :lol-test)
   2
   3 (defclass lol-test-server (standard-server)
   4   ())
   5
   6 (defclass lol-test-application (standard-application)
   7   ()
   8   (:default-initargs
   9     :url-prefix "/lisp-on-lines.test/"
  10 ;    :www-roots (list (cons "static/" (project-relative-pathname #P"wwwroot/")))
  11 ))
  12
  13 (defparameter *lol-test-ucw-application* (make-instance 'lol-test-application))
  14
  15 (defun make-backend ()
  16   (ucw::make-backend
  17    :httpd
  18    :host "localhost"
  19    :port 9090))
  20
  21 (defun make-server ()
  22   (make-instance
  23    'lol-test-server
  24    :backend (make-backend)))
  25
  26 (defparameter *lol-test-ucw-server* (make-server))
  27
  28 (register-application *lol-test-ucw-server* *lol-test-ucw-application*)
  29
  30 (defentry-point "index.ucw" (:application *lol-test-ucw-application*) ()
  31   (call 'lol-test-window))
  32
  33 (defun startup-lol-ucw-test ()
  34   (startup-server *lol-test-ucw-server*))
  35
  36 (defun shutdown-lol-ucw-test ()
  37  (shutdown-server *lol-test-ucw-server*))
  38
  39 (defcomponent lol-test-window (standard-window-component)
  40   ()
  41   (:default-initargs
  42       :body (make-instance 'lol-test-suite-component)))
  43
  44 (define-symbol-macro $window (lol-ucw:context.window-component *context*))
  45
  46 (define-symbol-macro $body (window-body $window))
  47
  48 (defcomponent lol-test-suite-component ()
  49   ((test :component lol-test-simple-action :accessor test)
  50    (component :component lol-test-render :accessor component)))
  51
  52 (define-symbol-macro $test (test $body))
  53
  54 (define-symbol-macro $component (component $body))
  55
  56 (defmethod render ((self lol-test-suite-component))
  57   (<:H1 "Lisp On Lines Web test suite")
  58      (render (slot-value self 'test))
  59   (<:div
  60    :style "border:1px solid black;"
  61    (render (slot-value self 'component))))
  62
  63 (defcomponent lol-test-render ()
  64   ((message :initform "test" :accessor message :initarg :message)))
  65
  66 (defmethod render ((self lol-test-render))
  67   (<:h3 :id "test-render"
  68         (<:as-html (format nil "Hello ~A." (message self)))))
  69
  70 (defcomponent lol-test-simple-action ()
  71   ())
  72
  73 (defmethod render ((self lol-test-simple-action))
  74   (<:ul
  75    (<:li (<lol:a
  76           :function
  77           (lambda ()
  78             (setf (message $component)
  79                   (format nil "~A : ~A" (message $component) "FUNCTION")))
  80           "Test <:A :FUNCTION type actions"))
  81    (<:li
  82     (<lol:a
  83      :action (setf (message $component)
  84                    (format nil "~A : ~A" (message $component) "ACTION"))
  85      "Test <:A :ACTION type actions"))
  86    (<:li
  87     (<lol:a
  88      :action* (make-action
  89                (lambda ()
  90                  (setf (message $component)
  91                        (format nil "~A : ~A" (message $component) "ACTION*"))))
  92      "Test <:A :ACTION* type actions"))
  93    (<:li
  94     (<lol:a
  95      :action (call-component $component (make-instance 'lol-test-answer))
  96      "Test CALL-COMPONENT/ANSWER-COMPONENT"))
  97    (<:li
  98     (<lol:a
  99      :action (call-component $component (make-instance 'lol-test-call-magic))
 100      "Test CALL/ANSWER MAGIC"))
 101    (<:li
 102     (<lol:a
 103      :action (call-component $component (make-instance 'lol-test-call-answer-action-magic))
 104      "Test CALL/ANSWER ACTION MAGIC"))
 105    (<:li
 106     (<lol:a
 107      :action (call-component $component (make-instance 'lol-test-simple-form))
 108      "Test Simple Form"))
 109    (<:li
 110     (<lol:a
 111      :action (call-component $component (make-instance 'lol-test-multi-submit-form))
 112      "Test Multi Form"))
 113    (<:li
 114     (<lol:a
 115      :action (call-component $component (make-instance 'lol-test-input))
 116      "Test Form input"))
 117 ))
 118
 119 (defcomponent lol-test-answer (lol-test-render) ()
 120   (:default-initargs :message "CALL was ok. Go Back will answer"))
 121
 122 (defmethod render :wrapping ((self lol-test-answer))
 123   (call-next-method)
 124   (<lol:a :action (answer-component self nil) "Go Back."))
 125
 126 (defcomponent lol-test-simple-form (lol-test-render) ()
 127   (:default-initargs :message "Testing Simple Form:"))
 128
 129 (defmethod render :wrapping ((self lol-test-simple-form))
 130   (call-next-method)
 131   (<lol:form
 132    :action (setf (message self) "Form Submitted")
 133    (<:submit))
 134   (<lol:a :action (answer-component self nil) "Go Back."))
 135
 136 (defcomponent lol-test-multi-submit-form (lol-test-render) ()
 137   (:default-initargs :message "Testing Simple Form:"))
 138
 139 (defmethod render :wrapping ((self lol-test-multi-submit-form))
 140   (call-next-method)
 141   (<lol:form
 142    :action (setf (message self) "Form Submitted")
 143    (<:submit)
 144    (<lol:submit :action (setf (message self) "Submit 2" )
 145                 :value "2")
 146    (<lol:submit :action (setf (message self) "Submit 3")
 147                 3))
 148   (<lol:a :action (answer-component self nil) "Go Back."))
 149
 150 (defcomponent lol-test-input (lol-test-render)
 151  ()
 152   (:default-initargs :message "Testing INPUTS"))
 153
 154 (defmethod render :wrapping ((self lol-test-input))
 155   (call-next-method)
 156   (<lol:form
 157    :function (constantly t)
 158    (<lol:input :type "text" :accessor (message self))
 159
 160    (<:submit)
 161   )
 162   (<lol:a :action (answer-component self nil) "Go Back."))
 163
 164
 165
 166 (defcomponent lol-test-call-magic (lol-test-render)
 167  ()
 168   (:default-initargs :message "Testing CALL magic."))
 169
 170 (defmethod render :wrapping ((self lol-test-call-magic))
 171   (call-next-method)
 172   (<lol:a :action (setf (message self) (call 'lol-test-answer-magic)) "Test CALL")
 173   (<:br)
 174   (<lol:a :action (answer-component self nil) "Go Back."))
 175
 176
 177
 178 (defcomponent lol-test-answer-magic (lol-test-render)
 179  ()
 180   (:default-initargs :message "Hit it to answer"))
 181
 182 (defmethod render :wrapping ((self lol-test-answer-magic))
 183   (call-next-method)
 184
 185   (<lol:a :action (answer "Ja, dat is vut ve answer" ) "IT! (hit here)"))
 186
 187 (defcomponent lol-test-call-answer-action-magic (lol-test-render)
 188  ()
 189   (:default-initargs :message "Hit it to answer"))
 190
 191 (defaction test-call-component ()
 192   (call 'lol-test-call-answer-action-magic :message "We made it"))
 193
 194 (defaction test-answer-component ()
 195   (answer "We Made IT BACK!!!"))
 196
 197 (defmethod render :wrapping ((self lol-test-call-answer-action-magic))
 198   (call-next-method)
 199   (<lol:a :action (test-call-component) "Test CALL from ACTION")
 200   (<:br)
 201   (<lol:a :action (test-answer-component) "Test ANSWER from ACTION"))
 202
 203
 204
 205
 206
 207