1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol-tests -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Self Test suite for WOL
8 ;;;; *************************************************************************
10 (in-package #:cl-user)
12 (defpackage #:wol-tests
13 (:use #:xlunit #:cl #:wol #:puri #:lml2 #:kmrcl)
14 (:export #:do-tests #:*all-tests*))
16 (in-package #:wol-tests)
18 (eval-when (:compile-toplevel :load-toplevel :execute)
19 (import '(wol::req-recode-uri-sans-session-id wol::request-uri
20 wol::request-decoded-uri-path wol::websession-from-req
21 wol::websession-key wol::+length-session-id+
22 wol::set-cookies-in-headers)))
27 (defclass test-keyed-url (test-case)
31 (defmethod set-up ((self test-keyed-url))
32 (let ((uri (parse-uri "/~abcdefg~/index.html")))
33 (setf (req self) (make-instance 'wol::http-request
35 :decoded-uri-path (render-uri uri nil)
37 (setf (ent self) (make-instance 'wol::entity
38 :project (make-instance 'wol::wol-project
39 :project-prefix "/")))))
41 (def-test-method test-returned-session ((self test-keyed-url) :run nil)
42 (assert-equal "abcdefg" (req-recode-uri-sans-session-id (req self)
45 (def-test-method test-recomputed-uri ((self test-keyed-url) :run nil)
46 (req-recode-uri-sans-session-id (req self) (ent self))
47 (assert-equal (render-uri (request-uri (req self)) nil)
50 (def-test-method test-decoded-uri ((self test-keyed-url) :run nil)
51 (req-recode-uri-sans-session-id (req self) (ent self))
52 (assert-equal (request-decoded-uri-path (req self))
56 (defclass test-keyed-url-2 (test-case)
60 (defmethod set-up ((self test-keyed-url-2))
61 (let ((uri (parse-uri "/app/~abcdefg~/index.html")))
62 (setf (req self) (make-instance 'wol::http-request
64 :decoded-uri-path (render-uri uri nil)
66 (setf (ent self) (make-instance 'wol::entity
67 :project (make-instance 'wol::wol-project
68 :project-prefix "/app/")))))
70 (def-test-method test-returned-session ((self test-keyed-url-2) :run nil)
71 (assert-equal "abcdefg" (req-recode-uri-sans-session-id (req self)
74 (def-test-method test-recomputed-uri ((self test-keyed-url-2) :run nil)
75 (req-recode-uri-sans-session-id (req self) (ent self))
76 (assert-equal (render-uri (request-uri (req self)) nil)
79 (def-test-method test-decoded-uri ((self test-keyed-url-2) :run nil)
80 (req-recode-uri-sans-session-id (req self) (ent self))
81 (assert-equal (request-decoded-uri-path (req self))
84 ;;; Non-keyed URL tests
86 (defclass test-non-keyed-url (test-case)
90 (defmethod set-up ((self test-non-keyed-url))
91 (let ((uri (parse-uri "/index.html")))
92 (setf (req self) (make-instance 'wol::http-request
94 :decoded-uri-path (render-uri uri nil)
96 (setf (ent self) (make-instance 'wol::entity
97 :project (make-instance 'wol::wol-project
98 :project-prefix "/")))))
100 (def-test-method test-returned-session ((self test-non-keyed-url) :run nil)
101 (assert-false (req-recode-uri-sans-session-id (req self) (ent self))))
103 (def-test-method test-recomputed-uri ((self test-non-keyed-url) :run nil)
104 (req-recode-uri-sans-session-id (req self) (ent self))
105 (assert-equal (render-uri (request-uri (req self)) nil)
108 (def-test-method test-decoded-uri ((self test-non-keyed-url) :run nil)
109 (req-recode-uri-sans-session-id (req self) (ent self))
110 (assert-equal (request-decoded-uri-path (req self))
113 (defclass test-non-keyed-url-2 (test-case)
115 (ent :accessor ent)))
117 (defmethod set-up ((self test-non-keyed-url-2))
118 (let ((uri (parse-uri "/app1/index.html")))
119 (setf (req self) (make-instance 'wol::http-request
121 :decoded-uri-path (render-uri uri nil)
123 (setf (ent self) (make-instance 'wol::entity
124 :project (make-instance 'wol::wol-project
125 :project-prefix "/app1/")))))
127 (def-test-method test-returned-session ((self test-non-keyed-url-2) :run nil)
128 (assert-false (req-recode-uri-sans-session-id (req self) (ent self))))
130 (def-test-method test-recomputed-uri ((self test-non-keyed-url-2) :run nil)
131 (req-recode-uri-sans-session-id (req self) (ent self))
132 (assert-equal (render-uri (request-uri (req self)) nil)
135 (def-test-method test-decoded-uri ((self test-non-keyed-url-2) :run nil)
136 (req-recode-uri-sans-session-id (req self) (ent self))
137 (assert-equal (request-decoded-uri-path (req self))
142 (defclass test-server (test-case)
143 ((wserver :accessor wserver)
144 (name :accessor name :initform "testproj")
145 (port :accessor port :initform 31322)
148 (defmethod set-up ((self test-server))
149 (setf (wserver self) (net.aserve:start :port (port self) :server :new))
150 (setq net.aserve::*enable-logging* nil)
151 (wol-project (name self) :index "index" :connector :aserve
152 :server (wserver self)))
155 (defmethod tear-down ((self test-server))
156 (net.aserve:shutdown :server (wserver self)))
159 (def-test-method test-server-index ((self test-server) :run nil)
160 (multiple-value-bind (body response-code headers uri)
161 (net.aserve.client:do-http-request
162 (render-uri (copy-uri (parse-uri "http://localhost/")
163 :port (port self)) nil)
165 (declare (ignore uri))
166 (assert-true (zerop (length body)))
167 (let ((redir (parse-uri
168 (cdr (assoc "Location" headers :test #'string-equal)))))
169 (assert-equal (uri-path redir) "/index.html"))
170 (assert-equal response-code 307)
173 (def-test-method test-prefix-index-1 ((self test-server) :run nil)
174 (wol-project (name self) :index "index" :connector :aserve
175 :project-prefix "/aprefix/" :server (wserver self))
177 (multiple-value-bind (body response-code headers uri)
178 (net.aserve.client:do-http-request
179 (render-uri (copy-uri (parse-uri "http://localhost/aprefix/")
180 :port (port self)) nil)
182 (declare (ignore uri))
183 (assert-equal "" body)
184 (let ((redir (parse-uri
185 (cdr (assoc "Location" headers :test #'string-equal)))))
186 (assert-equal (uri-path redir) "/aprefix/index.html"))
187 (assert-equal response-code 307)))
190 (def-test-method test-prefix-index-2 ((self test-server) :run nil)
191 (wol-project (name self) :index "index" :connector :aserve
192 :project-prefix "/aprefix/" :server (wserver self))
194 (multiple-value-bind (body response-code headers uri)
195 (net.aserve.client:do-http-request
196 (render-uri (copy-uri (parse-uri "http://localhost/ab")
197 :port (port self)) nil)
199 (declare (ignore uri headers))
200 (assert-equal response-code 404)
201 (assert-true (plusp (length body))))
203 (multiple-value-bind (body response-code headers uri)
204 (net.aserve.client:do-http-request
205 (render-uri (copy-uri (parse-uri "http://localhost/")
206 :port (port self)) nil)
208 (declare (ignore uri headers))
209 (assert-true (plusp (length body)))
210 (assert-equal response-code 404))
215 ;;; Test two projects
217 (defclass test-two-projects (test-case)
218 ((wserver :accessor wserver)
219 (name1 :accessor name1 :initform "testproj")
220 (prefix1 :accessor prefix1 :initform "/testprefix/")
221 (name2 :accessor name2 :initform "projtest")
222 (prefix12 :accessor prefix2 :initform "/prefixtest/")
223 (port :accessor port :initform 31323)
226 (defmethod set-up ((self test-two-projects))
227 (setf (wserver self) (net.aserve:start :port (port self) :server :new))
228 (setq net.aserve::*enable-logging* nil)
229 (wol-project (name1 self) :index "index1" :connector :aserve
230 :project-prefix (prefix1 self)
231 :server (wserver self))
232 (wol-project (name2 self) :index "index2" :connector :aserve
233 :project-prefix (prefix2 self)
234 :server (wserver self))
238 (defmethod tear-down ((self test-two-projects))
239 (net.aserve:shutdown :server (wserver self)))
241 (def-test-method test-two-project-index ((self test-two-projects) :run nil)
242 (multiple-value-bind (body response-code headers uri)
243 (net.aserve.client:do-http-request
244 (render-uri (copy-uri (parse-uri "http://localhost/testprefix/")
245 :port (port self)) nil)
247 (declare (ignore uri))
248 (assert-true (zerop (length body)))
249 (let ((redir (parse-uri
250 (cdr (assoc "Location" headers :test #'string-equal)))))
251 (assert-equal (uri-path redir) "/testprefix/index1.html"))
252 (assert-equal response-code 307))
253 (multiple-value-bind (body response-code headers uri)
254 (net.aserve.client:do-http-request
255 (render-uri (copy-uri (parse-uri "http://localhost/prefixtest/")
256 :port (port self)) nil)
258 (declare (ignore uri))
259 (assert-true (zerop (length body)))
260 (let ((redir (parse-uri
261 (cdr (assoc "Location" headers :test #'string-equal)))))
262 (assert-equal (uri-path redir) "/prefixtest/index2.html"))
263 (assert-equal response-code 307)
269 (defclass test-sessions (test-case)
270 ((wserver :accessor wserver)
271 (name :accessor name :initform "sessions")
272 (prefix :accessor prefix :initform "/")
273 (port :accessor port :initform 31324)
276 (defmethod set-up ((self test-sessions))
277 (setf (wserver self) (net.aserve:start :port (port self) :server :new))
278 (setq net.aserve::*enable-logging* nil)
279 (wol-project (name self) :index "index" :connector :aserve
281 :map '(("index" test-sessions-index))
282 :project-prefix (prefix self)
283 :server (wserver self)))
286 (defmethod tear-down ((self test-sessions))
287 (net.aserve:shutdown :server (wserver self)))
289 (defun test-sessions-index (req ent)
290 (let ((session (websession-from-req req)))
291 (with-wol-page (req ent)
292 (let ((url (make-wol-url "page" req ent)))
293 (format *html-stream* "index~%")
294 (format *html-stream* "~A~%" (websession-key session))
295 (format *html-stream* "~A~%" url)
298 (def-test-method test-sessions ((self test-sessions) :run nil)
299 (multiple-value-bind (body response-code headers uri)
300 (net.aserve.client:do-http-request
301 (render-uri (copy-uri (parse-uri "http://localhost/index.html")
302 :port (port self)) nil))
303 (declare (ignore uri))
304 (assert-equal response-code 200)
305 (let ((cookies (set-cookies-in-headers headers)))
306 (assert-equal (length cookies) 1))
307 (let ((lines (delimited-string-to-list body #\newline t)))
308 (assert-equal (length lines) 3)
309 (assert-equal (first lines) "index")
310 (assert-equal (length (second lines)) +length-session-id+)
311 (assert-equal (third lines)
312 (format nil "/~~~A~~/page.html" (second lines))))))
317 (defclass test-no-sessions (test-case)
318 ((wserver :accessor wserver)
319 (name :accessor name :initform "sessions")
320 (prefix :accessor prefix :initform "/")
321 (port :accessor port :initform 31325)
324 (defmethod set-up ((self test-no-sessions))
325 (setf (wserver self) (net.aserve:start :port (port self) :server :new))
326 (setq net.aserve::*enable-logging* nil)
327 (wol-project (name self) :index "index" :connector :aserve
329 :map '(("index" test-no-sessions-index))
330 :project-prefix (prefix self)
331 :server (wserver self)))
333 (defun test-no-sessions-index (req ent)
334 (let ((session (websession-from-req req)))
335 (with-wol-page (req ent)
336 (let ((url (make-wol-url "page" req ent)))
337 (format *html-stream* "index~%")
338 (format *html-stream* "~(~A~)~%" session)
339 (format *html-stream* "~A~%" url)
342 (defmethod tear-down ((self test-no-sessions))
343 (net.aserve:shutdown :server (wserver self)))
345 (def-test-method test-no-sessions ((self test-no-sessions) :run nil)
346 (multiple-value-bind (body response-code headers uri)
347 (net.aserve.client:do-http-request
348 (render-uri (copy-uri (parse-uri "http://localhost/index.html")
349 :port (port self)) nil))
350 (declare (ignore uri))
351 (assert-equal response-code 200)
352 (let ((cookies (set-cookies-in-headers headers)))
353 (assert-equal (length cookies) 0))
354 (let ((lines (delimited-string-to-list body #\newline t)))
355 (assert-equal (length lines) 3)
356 (assert-equal (first lines) "index")
357 (assert-equal (second lines) "nil")
358 (assert-equal (third lines) "/page.html"))))
363 (defclass all-tests (test-suite) ())
364 (defparameter *all-tests* (make-instance 'all-tests))
366 (add-test *all-tests* (get-suite test-keyed-url))
367 (add-test *all-tests* (get-suite test-keyed-url-2))
368 (add-test *all-tests* (get-suite test-non-keyed-url))
369 (add-test *all-tests* (get-suite test-non-keyed-url-2))
370 (add-test *all-tests* (get-suite test-server))
371 (add-test *all-tests* (get-suite test-two-projects))
372 (add-test *all-tests* (get-suite test-sessions))
373 (add-test *all-tests* (get-suite test-no-sessions))
376 (or (was-successful (textui-test-run *all-tests*))
377 (error "Failed tests")))