1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: project.lisp
6 ;;;; Purpose: Project handler for wol library
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: July 2003
10 ;;;; $Id: project.lisp,v 1.12 2003/08/10 07:38:37 kevin Exp $
12 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
17 (defun wol-project (name &key (project-prefix "/") map index
18 (sessions t) (session-lifetime 18000)
19 (reap-interval 300) server
24 (:modlisp ml:*ml-server*)
25 (:aserve net.aserve:*wserver*))))
28 (warn "Can't start project without server")
29 (return-from wol-project nil))
31 (multiple-value-bind (project found) (gethash name *active-projects*)
33 (setq project (make-instance 'wol-project))
34 (setf (gethash name *active-projects*) project))
36 (setf (project-name project) name)
37 (setf (project-prefix project) project-prefix)
38 (setf (project-map project) map)
39 (setf (project-index project) index)
40 (setf (project-server project) server)
41 (setf (project-connector project) connector)
42 (setf (lifetime (session-master project)) session-lifetime)
43 (setf (cookie-name (session-master project)) name)
45 (let ((hash (make-hash-table :size (length map) :test 'equal)))
46 (dolist (map-item map)
47 (setf (gethash (first map-item) hash) (second map-item)))
48 (setf (project-hash-map project) hash))
52 (setf (ml::processor server) 'wol-ml-processor))
54 (net.aserve:publish-prefix :prefix project-prefix
56 :function 'wol-aserve-processor)))
59 (when (null (sessions (session-master project)))
60 (setf (sessions (session-master project))
61 (make-hash-table :test 'eq)))
62 (when (sessions (session-master project))
63 (setf (sessions (session-master project)) nil)))
65 (setq *reap-interval* reap-interval)
66 (when (and sessions (null *reaper-process*))
67 (setq *reaper-process* (start-reaper)))))
69 (defun stop-wol-project (name)
70 (remhash name *active-projects*))
72 (defun wol-ml-processor (command)
73 "Processes an incoming modlisp command"
74 (let* ((req (command->request command
75 :ml-server *ml-server*))
76 (ent (make-entity-for-request req)))
78 (dispatch-request req ent)
79 (no-url-handler req ent))))
82 (defun wol-aserve-processor (as-req as-ent)
83 "Processes an incoming modlisp command"
84 (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
85 (if (entity-project ent)
86 (dispatch-request req ent)
87 (no-url-handler req ent))))
90 (defun make-request/ent-from-aserve (as-req as-ent)
91 (let* ((req (make-instance
93 :method (net.aserve:request-method as-req)
94 ;;:host (net.aserve:request-host as-req)
95 :raw-request (net.aserve::request-raw-request as-req)
96 :raw-uri (puri:intern-uri
98 (net.aserve:request-raw-uri as-req) nil))
100 (net.aserve::request-decoded-uri-path as-req)
101 :uri (puri:intern-uri
103 (net.aserve:request-uri as-req) nil))
104 :protocol (net.aserve:request-protocol as-req)
106 (net.aserve:request-protocol-string as-req)
107 :posted-content (net.aserve::request-request-body as-req)
108 :socket (net.aserve:request-socket as-req)
109 :headers (net.aserve::request-headers as-req)
110 :aserve-server net.aserve:*wserver*
111 :aserve-request as-req))
112 (project (find-project-for-request req))
113 (ent (make-instance 'entity :project project
114 :aserve-entity as-ent)))
118 (defun command->request (command &key ml-server)
119 "Convert a cl-modlisp command into a wol request"
121 (make-instance 'http-request
122 :host (header-value command :host)
123 :raw-request (header-value command :url)
124 :raw-uri (puri:intern-uri (header-value command :url))
125 :uri (puri:intern-uri (command->uri command))
126 :protocol (ensure-keyword
127 (header-value command :server-protocol))
128 :protocol-string (header-value command :server-protocol)
129 :method (ensure-keyword (header-value command :method))
130 :posted-content (header-value command :posted-content)
132 :socket *modlisp-socket*
133 :ml-server ml-server)))
134 (awhen (request-raw-uri req)
135 (setf (request-decoded-uri-path req) (puri:uri-path it)))
138 (defun header-slot-value (req slot)
139 (header-value (request-headers req) slot))
141 (defun command->uri (command)
142 (format nil "http://~A:~D~A"
143 (header-value command :host)
144 (header-value command :server-ip-port)
145 (header-value command :url)))
147 (defun is-index-request (req ent)
148 (string= (request-decoded-uri-path req)
149 (project-prefix (entity-project ent))))
151 (defun set-cookie (req ent)
152 (let ((session (websession-from-req req)))
153 (when (and session (websession-key session)
154 (not (eq :url (websession-method session))))
155 (let ((proj (entity-project ent)))
156 (ecase (project-connector proj)
158 (net.aserve:set-cookie-header (aserve-request req)
160 (entity-project ent))
164 :value (websession-key
165 (websession-from-req req))
172 (defun redirect-entity (page req ent &optional plist)
173 (let ((proj (entity-project ent))
175 (copy-uri (request-uri req)
176 :path (make-wol-url page req ent plist))
178 (ecase (project-connector proj)
180 (net.aserve:with-http-response
181 ((aserve-request req)
182 (entity-aserve-entity ent)
183 :response net.aserve:*response-temporary-redirect*)
185 (net.aserve:with-http-body
186 ((aserve-request req)
187 (entity-aserve-entity ent)
188 :headers `((:location . ,url))))))
190 (redirect-to-location url)))))
192 (defun dispatch-request (req ent)
195 (let ((proj (entity-project ent)))
196 (if (is-index-request req ent)
197 (redirect-entity (project-index proj) req ent)
199 (compute-uris req ent)
200 (dispatch-to-handler req ent)))))
202 (defun make-entity (&key project)
203 (make-instance 'entity :project project))
205 (defun make-entity-for-request (req)
206 (awhen (find-project-for-request req)
207 (make-entity :project it)))
209 (defun find-project-for-request (req)
210 (maphash (lambda (name project)
211 (declare (ignore name))
212 (when (and (eq (project-server project)
213 (or (request-aserve-server req)
214 (request-ml-server req)))
215 (request-matches-prefix
216 req (project-prefix project)))
217 (return-from find-project-for-request project)))
220 (defun request-matches-prefix (req prefix)
221 "Returns project if request matches project"
222 (string-starts-with prefix (request-decoded-uri-path req)))
225 (defun dispatch-to-handler (req ent)
226 (let ((handler (request-find-handler req ent))
227 (*wol-stream* (request-socket req)))
229 (handle-request handler req ent)
230 (no-url-handler req ent))))
232 (defun request-find-handler (req ent)
233 (nth-value 0 (gethash (request-page req)
234 (project-hash-map (entity-project ent)))))
236 (defun handle-request (handler req ent)
240 ((or symbol function)
241 (when (and (symbolp handler)
242 (not (fboundp handler)))
243 (cmsg "handler given a symbol without a function ~S" handler)
244 (return-from handle-request nil))
245 (let ((next-page (funcall handler req ent)))
248 (redirect-entity next-page req ent))
250 (redirect-entity (car next-page) req ent (cadr next-page)))
254 (cmsg "handler should return nil or a string, not ~S" next-page))))
257 (cmsg "string handler not supported: ~A" handler)
260 (cmsg "unknown handler type: ~S" handler)
265 (defun wol-version-string ()
266 (format nil "~{~D~^.~}" *wol-version*))
268 (defun alist-key->keyword (alist)
270 collect (cons (kmrcl:ensure-keyword (car a)) (cdr a))))
272 (defun request-query (req &key (uri t) (post t))
273 (aif (aserve-request req)
275 (net.aserve:request-query it :uri uri :post post))
276 (let ((desired (cons uri post)))
277 (if (equal desired (request-desired-query req))
278 ;; Same desired as cached
279 (request-query-alist req)
281 (setf (request-desired-query req) desired)
282 (setf (request-query-alist req)
284 (when (and uri (request-uri-query req))
285 (query-to-alist (request-uri-query req)))
286 (when (and post (request-posted-content req))
287 (query-to-alist (request-posted-content req))))))))))
289 (defun request-query-value (key req &key (uri t) (post t))
290 (aif (aserve-request req)
291 (net.aserve:request-query-value (string key) it :uri uri :post post)
292 (cdr (assoc key (request-query req :uri uri :post post)
295 (defun websession-variable (ws name)
297 (gethash name (websession-variables ws))))
299 (defun (setf websession-variable) (value ws name)
301 (setf (gethash name (websession-variables ws)) value)))
304 (defmacro with-wol-page ((req ent
305 &key (format :html) (precompute t) headers
308 `(if (request-aserve-server ,req)
309 (net.aserve:with-http-response
310 ((aserve-request ,req)
311 (entity-aserve-entity ,ent)
312 :content-type (ml::format-string ,format)
315 (302 net.aserve::*response-moved-permanently*)
316 (307 net.aserve::*response-temporary-redirect*)
317 (404 net.aserve::*response-not-found*)
318 (otherwise net.aserve::*response-ok*)))
319 (set-cookie ,req ,ent)
320 (net.aserve:with-http-body
321 ((aserve-request ,req)
322 (entity-aserve-entity ,ent)
324 (let ((*html-stream* net.html.generator:*html-stream*))
326 (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
330 (302 "302 Moved Permanently")
331 (307 "307 Temporary Redirect")
332 (404 "404 Not Found")
333 (otherwise "200 OK")))
337 (defmacro %with-wol-page ((req ent
338 &key (format :html) (precompute t) headers
339 (response-string "200 OK"))
341 (declare (ignore req ent))
342 (let ((fmt (gensym "FMT-"))
343 (precomp (gensym "PRE-"))
344 (result (gensym "RES-"))
345 (outstr (gensym "STR-"))
346 (stream (gensym "STRM-"))
347 (hdr (gensym "HDR-")))
348 `(let ((,fmt ,format)
349 (,precomp ,precompute)
350 ,result ,outstr ,stream)
351 (declare (ignorable ,stream))
352 (write-header-line "Status" ,response-string)
353 (write-header-line "Content-Type" (ml::format-string ,fmt))
354 (dolist (,hdr ,headers)
355 (write-header-line (car ,hdr) (cdr ,hdr)))
357 (write-string "end" *wol-stream*)
358 (write-char #\NewLine *wol-stream*))
360 (with-output-to-string (,stream)
361 (let ((*html-stream* (if ,precomp
364 (*wol-stream* (if ,precomp
367 (setq ,result (progn ,@body)))))
370 (write-header-line "Content-Length"
371 (write-to-string (length ,outstr)))
372 (write-header-line "Keep-Socket" "1")
373 (write-header-line "Connection" "Keep-Alive")
374 (write-string "end" *wol-stream*)
375 (write-char #\NewLine *wol-stream*)
376 (write-string ,outstr *wol-stream*)
377 (finish-output *wol-stream*)
378 (setq *close-modlisp-socket* nil))
380 (finish-output *wol-stream*)
381 (setq *close-modlisp-socket* t)))
385 (defun no-url-handler (req ent)
386 (with-wol-page (req ent :response-code 404)
390 (:title "404 - NotFound"))
393 (:p "The request for "
394 (:b (:write-string (render-uri (request-uri req) nil)))
395 " was not found on this server.")
398 (:write-string (wol-version-string)))))))))