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.3 2003/07/18 21:34:18 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
25 (:modlisp ml:*ml-server*)
26 (:aserve net.aserve:*wserver*))))
29 (warn "Can't start project without server")
30 (return-from wol-project nil))
32 (multiple-value-bind (project found) (gethash name *active-projects*)
34 (setq project (make-instance 'wol-project))
35 (setf (gethash name *active-projects*) project))
37 (setf (project-name project) name)
38 (setf (project-prefix project) project-prefix)
39 (setf (project-map project) map)
40 (setf (project-index project) index)
41 (setf (project-server project) server)
42 (setf (project-connector project) connector)
43 (setf (lifetime (session-master project)) session-lifetime)
44 (setf (cookie-name (session-master project)) name)
46 (let ((hash (make-hash-table :size (length map) :test 'equal)))
47 (dolist (map-item map)
48 (setf (gethash (first map-item) hash) (second map-item)))
49 (setf (project-hash-map project) hash))
53 (setf (ml::processor server) 'wol-ml-processor))
55 (net.aserve:publish-prefix :prefix project-prefix
57 :function 'wol-aserve-processor)))
60 (when (null (sessions (session-master project)))
61 (setf (sessions (session-master project))
62 (make-hash-table :test 'eq)))
63 (when (sessions (session-master project))
64 (setf (sessions (session-master project)) nil)))
66 (setq *reap-interval* reap-interval)
67 (when (and sessions (null *reaper-process*))
68 (setq *reaper-process* (start-reaper)))))
70 (defun wol-ml-processor (command)
71 "Processes an incoming modlisp command"
72 (let* ((req (command->request command
73 :ml-server *ml-server*))
74 (ent (make-entity-for-request req)))
76 (dispatch-request req ent)
77 (no-url-handler req ent))))
80 (defun wol-aserve-processor (as-req as-ent)
81 "Processes an incoming modlisp command"
82 (let* ((req (make-request-from-aserve as-req))
83 (ent (make-entity-from-aserve req as-ent)))
84 (dispatch-request req ent)))
86 (defun make-request-from-aserve (as-req)
87 (make-instance 'http-request
88 :method (net.aserve:request-method as-req)
89 ;;:host (net.aserve:request-host as-req)
90 :raw-uri (net.uri:render-uri
91 (net.aserve:request-raw-uri as-req)
93 :uri (net.uri:render-uri
94 (net.aserve:request-uri as-req)
96 :protocol (net.aserve:request-protocol as-req)
98 (net.aserve:request-protocol-string as-req)
99 :posted-content (net.aserve::request-request-body as-req)
100 :socket (net.aserve:request-socket as-req)
101 :aserve-server net.aserve:*wserver*
102 :aserve-request as-req))
104 (defun make-entity-from-aserve (req as-ent)
105 (make-instance 'entity
106 :project (find-project-for-request req)
107 :aserve-entity as-ent))
110 (defun command->request (command &key ml-server)
111 "Convert a cl-modlisp command into a wol request"
113 (make-instance 'http-request
114 :host (header-value command :host)
115 :raw-uri (header-value command :url)
116 :uri (create-uri (header-value command :host)
118 command :server-ip-port)
120 (header-value command :url))
121 :protocol (ensure-keyword (header-value command :server-protocol))
122 :protocol-string (header-value command :server-protocol)
123 :method (ensure-keyword (header-value command :method))
124 :posted-content (header-value command :posted-content)
126 :socket *modlisp-socket*
127 :ml-server ml-server)))
130 (defun header-slot-value (req slot)
131 (header-value (request-headers req) slot))
133 (defun create-uri (host port page)
134 (format nil "http://~A:~D~A" host port page))
136 (defun is-index-request (req ent)
137 (string= (request-raw-uri req)
138 (project-prefix (entity-project ent))))
140 (defun redirect-entity (page ent)
141 (redirect-to-location
142 (format nil "~A~A" (project-prefix (entity-project ent)) page)))
144 (defun dispatch-request (req ent)
145 (let ((proj (entity-project ent)))
146 (if (is-index-request req ent)
147 (redirect-entity (project-index proj) ent)
149 (request-decompile-uri req ent)
150 (compute-session req ent)
151 (dispatch-to-handler req ent)))))
153 (defun make-entity (&key project)
154 (make-instance 'entity :project project))
156 (defun make-entity-for-request (req)
157 (awhen (find-project-for-request req)
158 (make-entity :project it)))
160 (defun find-project-for-request (req)
161 (maphash (lambda (name project)
162 (declare (ignore name))
163 (when (request-matches-prefix req (project-prefix project))
164 (return-from find-project-for-request project)))
167 (defun request-matches-prefix (req prefix)
168 "Returns project if request matches project"
169 (string-starts-with prefix (request-raw-uri req)))
172 (defun dispatch-to-handler (req ent)
173 (let ((handler (request-find-handler req ent))
174 (*wol-stream* (request-socket req)))
176 (handle-request handler req ent)
177 (no-url-handler req ent))))
179 (defun request-find-handler (req ent)
180 (nth-value 0 (gethash (request-page req)
181 (project-hash-map (entity-project ent)))))
183 (defun handle-request (handler req ent)
187 ((or symbol function)
188 (when (and (symbolp handler)
189 (not (fboundp handler)))
190 (cmsg "handler given a symbol without a function ~S" handler)
191 (return-from handle-request nil))
192 (let ((next-page (funcall handler req ent)))
195 (redirect-entity next-page ent))
199 (cmsg "handler should return nil or a string, not ~S" next-page))))
202 (cmsg "string handler not supported: ~A" handler)
205 (cmsg "unknown handler type: ~S" handler)
210 (defun wol-version-string ()
211 (format nil "~{~D~^.~}" *wol-version*))
213 (defun request-query (req &key (uri t) (post t))
215 (when (and uri (request-uri-query req))
216 (aif (request-query-alist req)
218 (setf (request-query-alist req)
219 (query-to-alist (request-uri-query req)))))
220 (when (and post (request-posted-content req))
221 (query-to-alist (request-posted-content req)))))
223 (defun request-query-value (key req &key (uri t) (post t))
224 (cdr (assoc key (request-query req :uri uri :post post)
227 (defun websession-variable (ws name)
229 (gethash name (websession-variables ws))))
231 (defun (setf websession-variable) (value ws name)
233 (setf (gethash name (websession-variables ws)) value)))
236 (defmacro with-wol-page ((req ent
237 &key (format :html) (precompute t) headers)
239 (let ((fmt (gensym "FMT-"))
240 (precomp (gensym "PRE-"))
241 (result (gensym "RES-"))
242 (outstr (gensym "STR-"))
243 (stream (gensym "STRM-"))
244 (hdr (gensym "HDR-")))
245 `(let ((,fmt ,format)
246 (,precomp ,precompute)
247 ,result ,outstr ,stream)
248 (declare (ignorable ,stream))
249 (write-header-line "Status" "200 OK")
250 (write-header-line "Content-Type" (ml::format-string ,fmt))
251 (dolist (,hdr ,headers)
252 (write-header-line (car ,hdr) (cdr ,hdr)))
254 (write-string "end" *wol-stream*)
255 (write-char #\NewLine *wol-stream*))
257 (with-output-to-string (,stream)
258 (let ((*html-stream* (if ,precomp
261 (*wol-stream* (if ,precomp
264 (setq ,result (progn ,@body)))))
267 (write-header-line "Content-Length"
268 (write-to-string (length ,outstr)))
269 (write-header-line "Keep-Socket" "1")
270 (write-header-line "Connection" "Keep-Alive")
271 (write-string "end" *wol-stream*)
272 (write-char #\NewLine *wol-stream*)
273 (write-string ,outstr *wol-stream*)
274 (finish-output *wol-stream*)
275 (setq *close-modlisp-socket* nil))
277 (finish-output *wol-stream*)
278 (setq *close-modlisp-socket* t)))
282 (defun no-url-handler (req ent)
283 (with-wol-page (req ent)
287 (:title "404 - NotFound"))
290 (:p "The request for "
291 (:b (:write-string (request-uri req)))
292 " was not found on this server.")
295 (:write-string (wol-version-string)))))))))