/[ht-ajax]/test/test-ht-ajax.lisp
ViewVC logotype

Contents of /test/test-ht-ajax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Nov 14 21:17:43 2008 UTC (5 years, 5 months ago) by xlopez
File size: 4561 byte(s)
Initial commit, version 0.0.7.
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
2 ;;;
3 ;;; Copyright (c) 2007, Ury Marshak
4 ;;; The code comes with a BSD-style license, so you can basically do
5 ;;; with it whatever you want. See the file LICENSE for details.
6 ;;;
7
8 (in-package #:ht-ajax-test)
9
10 (declaim (optimize (space 0) (speed 0) (safety 3) (debug 3)))
11
12
13 (defvar *this-file* (load-time-value
14 (or #.*compile-file-pathname* *load-pathname*)))
15
16 (defvar *this-dir* (make-pathname :host (pathname-host *this-file*)
17 :device (pathname-device *this-file*)
18 :directory (pathname-directory *this-file*)))
19
20
21 ;; (defmacro debug-output (value)
22 ;; `(ignore-errors
23 ;; (swank::with-connection ((swank::default-connection)) (print ,value))))
24
25
26
27 ;;
28 (defparameter +templates-root+ (namestring *this-dir*))
29
30 (defparameter +web-root-base+ "/hunchentoot/test")
31 (defparameter +web-root+ (concatenate 'string +web-root-base+ "/"))
32 (defparameter +static-web-root+ (concatenate 'string +web-root+ "static/"))
33
34 (defparameter +ajax-handler-url+ (concatenate 'string +web-root+ "ajax-hdlr"))
35
36 (defparameter +static-files-root+ (concatenate 'string +templates-root+ "../static/"))
37
38
39
40 ;;
41 (defun expand-web-addr (short-addr)
42 (concatenate 'string +web-root+ short-addr ))
43
44
45 (defun expand-template (templ-short-name &optional args)
46 (let ((templ-full-name (merge-pathnames templ-short-name +templates-root+)))
47 (with-output-to-string (*default-template-output*)
48 (funcall #'fill-and-print-template templ-full-name args :external-format :utf-8))))
49
50
51 (defun expand-template-with-prologue (templ-short-name &optional args prologue)
52 (let ((page (expand-template templ-short-name args)))
53 (regex-replace "(?s)<body[^>]*>" page (list :match prologue))))
54
55 ;;
56
57
58 (defparameter *ajax-processor* (ht-ajax:make-ajax-processor
59 :type :prototype
60 :server-uri +ajax-handler-url+
61 :js-file-uris "static/"
62 :js-debug nil
63 :js-compression t
64 :virtual-js-file t))
65
66
67 ;;
68
69
70 (defun test ()
71 (no-cache)
72 ;; (setf (content-type) "text/html; charset=utf-8")
73 ;; (setf (reply-external-format) hunchentoot::+utf-8+)
74
75 (expand-template-with-prologue "test-ajax.tmpl.html" '()
76 (ht-ajax:generate-prologue *ajax-processor*)))
77
78
79 (let ((counter 0))
80 (ht-ajax:defun-ajax get-counter () (*ajax-processor*)
81 (concatenate 'string
82 "<span>" "counter: "
83 (princ-to-string (incf counter))
84 "</span>")))
85
86
87 (ht-ajax:defun-ajax testfunc (command) (*ajax-processor* :method :post)
88 (prin1-to-string (handler-case (eval (read-from-string command nil))
89 (error (c) (format nil "~A" c)))))
90
91
92 (ht-ajax:defun-ajax testjson () (*ajax-processor* :method :get
93 :json t)
94 "{\"p\":[1,2,3,5,7,11]}")
95
96
97 ;;
98
99 (defun string-starts-with (string prefix)
100 ;; (from Hunchentoot)
101 (let ((mismatch (mismatch string prefix :test #'char=)))
102 (or (null mismatch)
103 (>= mismatch (length prefix)))))
104
105 ;;
106 (defun page404 ()
107 (no-cache)
108 (setf (return-code *reply*) +http-not-found+)
109 (throw 'handler-done nil))
110
111
112 (defparameter +urls-alist+ '(("test" . test)) )
113
114
115 (defun serve-static ()
116 "Handle a request for a file under static/ directory"
117 (let* ((script-name (script-name))
118 (fname (subseq script-name (length +static-web-root+)))
119 (fullname (concatenate 'string +static-files-root+ fname)))
120 (handle-static-file fullname)))
121
122
123 (defun dispatch (request)
124 (let ((script-name (script-name request)))
125 (cond
126 ((or (string-equal script-name +web-root-base+)
127 (string-equal script-name +web-root+)) 'root-url) ; go to the start page
128 ((string-starts-with script-name +ajax-handler-url+) ; process AJAX requests
129 (ht-ajax:get-handler *ajax-processor*))
130 ((not (string-starts-with script-name +web-root+)) nil) ; do not handle this request
131 ((string-starts-with script-name +static-web-root+) 'serve-static) ; serve static file
132
133 (t ; normal processing
134 (let* ((name (subseq script-name (length +web-root+)))
135 (handler (assoc name +urls-alist+ :test #'string-equal)))
136
137 (if handler
138 (cdr handler)
139 'page404))))))
140
141
142
143 (pushnew 'dispatch *dispatch-table* :test #'eq)

  ViewVC Help
Powered by ViewVC 1.1.5