/
application-handler.lisp
146 lines (133 loc) · 5.77 KB
/
application-handler.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
(in-package :easyweb)
(defparameter *acceptor-name* nil)
(defparameter *application-contexts* nil)
(defstruct (application-context
(:conc-name context-))
name
acceptor-status-list ;default acceptors of application
mappings)
(defstruct (url-mapping
(:conc-name mapping-))
uri
handler
request-method)
(defun application-start (application-name &key (port *listen-port*) (address *listen-address*))
(when application-name
(let* ((starter (get-easy-starter :address address
:port port))
(acceptor (easy-starter-acceptor starter)))
(when (and starter acceptor)
(application-load application-name :acceptor-name (hunchentoot:acceptor-name acceptor))
(pushnew application-name (easy-starter-applications starter))
(hunchentoot:start acceptor)
(format t "Application started: ~S~%" application-name)))))
(defun application-stop (application-name &optional (acceptor-name (format nil
"(~A . ~A)"
*listen-address*
*listen-port*)))
(when application-name
(let ((starter (gethash acceptor-name *acceptor-table*)))
(when starter
(let ((acceptor (easy-starter-acceptor starter)))
(when acceptor
(application-unload application-name :acceptor-name (hunchentoot:acceptor-name acceptor))
(format t "Application stopped: ~S~%" application-name)
(setf (easy-starter-applications starter) (delete-if #'(lambda(obj)
(string= application-name obj))
(easy-starter-applications starter)))
(when (zerop (length (easy-starter-applications starter)))
(hunchentoot:stop acceptor)
(format t "Acceptor stopped: ~S~%" (hunchentoot:acceptor-name acceptor)))))))))
(defun application-load (application-name &key acceptor-name)
(loop
for context in *application-contexts*
when (and context
(string-equal application-name (context-name context)))
do (if (null acceptor-name)
(setf (context-acceptor-status-list context) (list (cons (nil t))))
(let ((target (member acceptor-name (context-acceptor-status-list context) :test #'string= :key #'car)))
(if target
(setf (cdar (context-acceptor-status-list context)) t)
(push (cons acceptor-name t) (context-acceptor-status-list context)))))))
(defun application-unload (application-name &key acceptor-name)
(if (null acceptor-name)
"Acceptor-name required!"
(loop
for context in *application-contexts*
when (and context
(string-equal application-name (context-name context)))
do (setf (context-acceptor-status-list context) (delete-if #'(lambda(el)
(and (car el)
(string= (car el) acceptor-name)))
(context-acceptor-status-list context))))))
(defmacro define-url-patterns (prefix &body body)
`(progn
,@(mapcar #'(lambda(mapping)
(map-one-pattern mapping prefix))
body)))
(defun map-one-pattern (mapping prefix)
(let ((uri (car mapping)))
(let ((uri-type (car uri))
(uri-content (format nil "~A~A" prefix (cadr uri)))
(handler (cadr mapping))
(request-type (or (caddr mapping)
:BOTH)))
`(define-url-handler (,handler :uri ,(cons uri-type uri-content) :default-request-type ,request-type)))))
(defmacro define-url-handler (description)
(when (atom description)
(setq description (list description)))
(destructuring-bind (name &key uri
(default-parameter-type ''string)
(default-request-type (cond ((eq (search "##get" name :test #'string-equal)
(- (length name) 4))
:GET)
((eq (search "##post" name :test #'string-equal)
(- (length name) 5))
:POST)
(t
:BOTH))))
description
`(let ((context (loop for app in *application-contexts*
when (string= (context-name app) *application-name*)
do (return app))))
(unless context
(setf context (make-application-context :name *application-name*))
(push context *application-contexts*))
(setf (context-mappings context) (delete-if #'(lambda (a-mapping)
(and (equal ,(cdr uri) (cdr (mapping-uri a-mapping)))
(eq ,default-request-type (mapping-request-method a-mapping))))
(context-mappings context)))
(push (make-url-mapping :uri (cons ,(car uri) ,(cdr uri))
:handler ',name
:request-method ',default-request-type)
(context-mappings context)))))
(defun dispatch-url-handlers (request)
(loop
for context in *application-contexts*
when context
do (let ((asl (context-acceptor-status-list context)))
(loop
for mapping in (context-mappings context)
do (let ((uri (mapping-uri mapping)))
(let ((uri-type (car uri))
(uri-content (cdr uri))
(easy-handler (mapping-handler mapping))
(request-type (mapping-request-method mapping)))
;(format t "~A" (cdr (find (hunchentoot:acceptor-name hunchentoot:*acceptor*) asl :test #'string= :key #'car)))
(when (and (cdr (find (hunchentoot:acceptor-name hunchentoot:*acceptor*) asl :test #'string= :key #'car))
(or (eq :BOTH request-type)
(eq request-type (hunchentoot:request-method request)))
(cond ((stringp uri-content)
(case uri-type
(:absolute ;;ABOLUTE matching
(string= uri-content (hunchentoot:script-name request)))
(:prefix ;;PREFIX matching
(let ((mismatch (mismatch (hunchentoot:script-name request) uri-content
:test #'char=)))
(and (or (null mismatch)
(>= mismatch (length uri-content))))))
(:regex ;;Regular EXP. matching
(let ((scanner (cl-ppcre:create-scanner uri-content)))
(not (null (cl-ppcre:scan scanner (hunchentoot:script-name request))))))))
(t (funcall uri-content request))))
(return-from dispatch-url-handlers easy-handler))))))))